PSOSPMUT ;BIRM/MFR - State Prescription Monitoring Program Utilities ;10/07/12
;;7.0;OUTPATIENT PHARMACY;**408,451,549,625,630,772**;DEC 1997;Build 105
;
EXPORT(BATCHIEN,MODE,BCKGRND,DEBUG,FLUSH) ; Export a SPMP Batch
;Input: BATCHIEN - Pointer to #58.41
; MODE - "VIEW" or "EXPORT"
; BCKGRND - Background? (1:YES / 0:NO)
; DEBUG - Debug Mode? (1:YES / 0:NO)
; FLUSH - Flush host? (1:YES / 0:NO)
N X,RX,STATEIEN,PSOASVER,TRXTYPE,PSOTTCNT,PSOTPCNT,SITEIEN,RXIEN,FILLNUM,FILLIEN,PATIEN,DFN,VADM
N RTSDATA,DATETIME,VAPA,XX,ASAP,LOCDIR,EXPFILE,EXPFILE2,FTPFILE,INPTFILE,DIE,DR,DA,PSOFTPOK,FILES
N PSODELOK,PSOOS,RTSONLY,PSOSTIP,PSOSTUSR,PSONAME,PSOPORT,PSOAUTO,PSOSTDIR,PSOFLEXT,RENAME,DRUGIEN
N PREIEN,RPHIEN,RTSREC,RXNODE,ZRS,ZRNODE,DEA,PSOVER
S BCKGRND=+$G(BCKGRND),DEBUG=+$G(DEBUG),FLUSH=+$G(FLUSH) K ^TMP("PSOSPMEX",$J),ZRDEA
;
I +$$SPOK($$GET1^DIQ(58.42,BATCHIEN,1,"I"))=-1 D Q
. D LOGERROR(BATCHIEN,0,$P($$SPOK($$GET1^DIQ(58.42,BATCHIEN,1,"I")),"^",2),BCKGRND)
;
; The LOCK below prevents two concurrent transmission processes from getting the same filename
F S DATETIME=$P($$FMTHL7^XLFDT($$HTFM^XLFDT($H)),"-") L +@("PMP"_DATETIME):0 Q:$T H 2
;
S STATEIEN=$$GET1^DIQ(58.42,BATCHIEN,1,"I")
S PSOASVER=$$GET1^DIQ(58.41,STATEIEN,1,"I")
I $$GET1^DIQ(58.42,BATCHIEN,2,"I")="ZR" S PSOASVER=$$GET1^DIQ(58.41,STATEIEN,20) ;Zero Reporting
S PSOFLEXT=$$GET1^DIQ(58.41,STATEIEN,6)
S RENAME=$$GET1^DIQ(58.41,STATEIEN,17,"I")
S PSOSTIP=$$GET1^DIQ(58.41,STATEIEN,7)
S PSOPORT=$$GET1^DIQ(58.41,STATEIEN,9)
;
; The commands below will first 'flush' and then add the IP Address to the known_hosts file
S PSOVER=$$UP^XLFSTR($$VERSION^%ZOSV(1))
I MODE="EXPORT",$$OS^%ZOSV()="UNIX",(PSOVER["CACHE")!(PSOVER["IRIS") D ;PSO*7*630
. I DEBUG,FLUSH X "S PV=$ZF(-1,""ssh-keygen -R ""_PSOSTIP)"
. X "S PV=$ZF(-1,""ssh -oBatchMode=yes -oStrictHostKeyChecking=no -oLogLevel=quiet"_$S(PSOPORT:" -oPort="_PSOPORT,1:"")_" "_PSOSTIP_""")"
;
S PSOSTUSR=$$GET1^DIQ(58.41,STATEIEN,8)
S PSOSTDIR=$$GET1^DIQ(58.41,STATEIEN,10)
S PSOAUTO=$S($$GET1^DIQ(58.41,STATEIEN,13,"I")="A":1,1:0)
S PSOOS=$$OS^%ZOSV()
;
I MODE="EXPORT",'$G(BCKGRND) W !!,"Exporting Batch #",BATCHIEN,":",!
;
S RX=0
F S RX=$O(^PS(58.42,BATCHIEN,"RX",RX)) Q:'RX D
. S RXNODE=^PS(58.42,BATCHIEN,"RX",RX,0)
. S RXIEN=+RXNODE,FILLNUM=$P(RXNODE,"^",2),PATIEN=$$GET1^DIQ(52,RXIEN,2,"I")
. I MODE="EXPORT",$P(RXNODE,"^",3)'="V",'$$RXRLDT^PSOBPSUT(RXIEN,FILLNUM) Q
. ; PSO*7*625:PSU-14 - Allow VOID Export of Released Prescriptions in RX Batch Only
. I MODE="EXPORT",$P(RXNODE,"^",3)="V",$$RXRLDT^PSOBPSUT(RXIEN,FILLNUM),($$GET1^DIQ(58.42,BATCHIEN,2,"I")'="RX") Q ; PSO*7*625:PSU-14
. ; Always the Pharmacy Division for the Original Fill
. S SITEIEN=$$RXSITE^PSOBPSUT(RXIEN,0)
. S ^TMP("PSOSPMEX",$J,SITEIEN,PATIEN,RXIEN,FILLNUM)=$P(RXNODE,"^",3)
;
I $$GET1^DIQ(58.41,STATEIEN,20)'="",$$GET1^DIQ(58.42,BATCHIEN,2,"I")="ZR" D ;Zero report
. S ZRS=0 S SITEIEN=""
. F S ZRS=$O(^PS(58.42,BATCHIEN,"ZRS",ZRS)) Q:'ZRS D
. . S ZRNODE=^PS(58.42,BATCHIEN,"ZRS",ZRS,0)
. . S SITEIEN=+ZRNODE,DEA=$P(ZRNODE,"^",2)
. . S ZRDEA(DEA)=SITEIEN
. N DEA S (DEA,SITEIEN)=""
. F S DEA=$O(ZRDEA(DEA)) Q:DEA="" D
. . S SITEIEN=ZRDEA(DEA),^TMP("PSOSPMEX",$J,SITEIEN)=""
;
I '$D(^TMP("PSOSPMEX",$J)) D L -@("PMP"_DATETIME) Q
. D LOGERROR(BATCHIEN,0,"There were no eligible prescriptions in the batch #"_BATCHIEN,BCKGRND)
;
I MODE="VIEW",PSOASVER'="1995" S XX="",$P(XX,"-",80)="" W !,XX,!
I MODE="EXPORT" D I $P(FILES,"^",1)=-1 L -@("PMP"_DATETIME) Q
. S RTSONLY=0 I $$GET1^DIQ(58.42,BATCHIEN,2,"I")="VD" S RTSONLY=1
. I PSOOS["VMS" S LOCDIR=$$GET1^DIQ(58.41,STATEIEN,4)
. I PSOOS["UNIX" D
. . S LOCDIR=$$GET1^DIQ(58.41,STATEIEN,15)
. . I '$$DIREXIST^PSOSPMU1(LOCDIR) D MAKEDIR^PSOSPMU1(LOCDIR)
. S FILES=$$PREPFILE^PSOSPMU1(STATEIEN,DATETIME,RTSONLY,DEBUG)
. I $P(FILES,"^",1)=-1 D LOGERROR(BATCHIEN,0,$P(FILES,"^",2),BCKGRND) Q
. S EXPFILE=$P(FILES,"^",2)
. S FTPFILE=$P(FILES,"^",3)
. S INPTFILE=$P(FILES,"^",4)
. S LOGFILE=$P(FILES,"^",5)
. S EXPFILE2=$P(FILES,"^",6)
. I 'BCKGRND W !,$S('PSOAUTO:"Step 1: ",1:""),"Writing to file ",LOCDIR_EXPFILE,"..."
. D OPEN^%ZISH("EXPFILE",LOCDIR,EXPFILE,"W")
. I POP D LOGERROR(BATCHIEN,0,"Export File <"_LOCDIR_EXPFILE_"> could not be created.",BCKGRND) S FILES=-1 Q
. D USE^%ZISUTL("EXPFILE")
;----------------------------- ASAP Data Output (1995) -------------------------------
I PSOASVER="1995" D
. S (SITEIEN,PATIEN,RXIEN)=0
. F S SITEIEN=$O(^TMP("PSOSPMEX",$J,SITEIEN)) Q:'SITEIEN D
. . F S PATIEN=$O(^TMP("PSOSPMEX",$J,SITEIEN,PATIEN)) Q:'PATIEN D
. . . K VADM,VAPA,PSONAME S DFN=PATIEN D DEM^VADPT,ADD^VADPT,SETNAME(PATIEN)
. . . F S RXIEN=$O(^TMP("PSOSPMEX",$J,SITEIEN,PATIEN,RXIEN)) Q:'RXIEN D
. . . . S FILLNUM=""
. . . . F S FILLNUM=$O(^TMP("PSOSPMEX",$J,SITEIEN,PATIEN,RXIEN,FILLNUM)) Q:FILLNUM="" D
. . . . . S RECTYPE=^TMP("PSOSPMEX",$J,SITEIEN,PATIEN,RXIEN,FILLNUM)
. . . . . K RTSDATA I RECTYPE="V" D LOADRTS^PSOSPMU1(RXIEN,FILLNUM,.RTSDATA)
. . . . . W $$ASAP95^PSOASAP0(RXIEN,+FILLNUM),!
;------------------------- ASAP Data Output (3.0 and above) --------------------------
I PSOASVER'="1995" D
. S TRXTYPE="S",PSOTTCNT=0
. D LOADASAP^PSOSPMU0(PSOASVER,"B",.ASAP)
. S (SITEIEN,PATIEN,RXIEN)=0
. ;Writing Level 1: Transaction Header, Information Source
. D WRITELEV(1,"ASAP")
. F S SITEIEN=$O(^TMP("PSOSPMEX",$J,SITEIEN)) Q:'SITEIEN D
. . S PSOTPCNT=0
. . ;Writing Level 2: Pharmacy Header
. . D WRITELEV(2,"ASAP")
. . ;Zero Reporting
. . I $$GET1^DIQ(58.42,BATCHIEN,2,"I")="ZR" D
. . . ;Zero Reporting Writing Level 3: Patient Detail
. . . D WRITELEV(3,"ASAP")
. . . ;Zero Reporting Writing Level 4: Prescription Detail
. . . D WRITELEV(4,"ASAP")
. . F S PATIEN=$O(^TMP("PSOSPMEX",$J,SITEIEN,PATIEN)) Q:'PATIEN D
. . . K VADM,VAPA,PSONAME S DFN=PATIEN D DEM^VADPT,ADD^VADPT,SETNAME(PATIEN)
. . . S (DRUGIEN,FILLNUM,FILLIEN,PREIEN,RPHIEN,RTSREC)=0
. . . ;Writing Level 3: Patient Detail
. . . D WRITELEV(3,"ASAP")
. . . F S RXIEN=$O(^TMP("PSOSPMEX",$J,SITEIEN,PATIEN,RXIEN)) Q:'RXIEN D
. . . . S FILLNUM="",DRUGIEN=$$GET1^DIQ(52,RXIEN,6,"I")
. . . . F S FILLNUM=$O(^TMP("PSOSPMEX",$J,SITEIEN,PATIEN,RXIEN,FILLNUM)) Q:FILLNUM="" D
. . . . . S FILLIEN=$S(FILLNUM["P":+$P(FILLNUM,"P",2),1:+FILLNUM)
. . . . . S RECTYPE=^TMP("PSOSPMEX",$J,SITEIEN,PATIEN,RXIEN,FILLNUM)
. . . . . S PREIEN=$$PREIEN(RECTYPE,RXIEN,FILLNUM)
. . . . . S RPHIEN=$$RPHIEN(RECTYPE,RXIEN,FILLNUM)
. . . . . S RTSREC=0 K RTSDATA I RECTYPE="V" S RTSREC=1 D LOADRTS^PSOSPMU1(RXIEN,FILLNUM,.RTSDATA)
. . . . . ;Writing Level 4: Prescription Detail
. . . . . D WRITELEV(4,"ASAP")
. . ;Writing Level 5: Pharmacy Trailer
. . D WRITELEV(5,"ASAP")
. ;Writing Level 6: Transaction Trailer
. D WRITELEV(6,"ASAP")
; Close the file
I MODE="EXPORT" D CLOSE^%ZISH("EXPFILE") I 'BCKGRND W "Done."
;------------------------- sFTP Transmission to the State -----------------------------
I MODE="VIEW",PSOASVER'="1995" S XX="",$P(XX,"-",80)="" W !,XX
S (PSOFTPOK,PSODELOK)=""
I MODE="EXPORT" D
. ; Automated Transmission (RSA keys)
. I PSOAUTO D
. . I 'BCKGRND W !!,"Transmitting file to the State (",$$GET1^DIQ(58.41,STATEIEN,7),")...",!
. . S PSOFTPOK=$$FTPFILE^PSOSPMU1(PSOSTIP,PSOSTUSR,LOCDIR,FTPFILE,EXPFILE,INPTFILE,LOGFILE,PSOPORT,DEBUG)
. ; Manual Transmission (Password)
. K DTOUT,DUOUT
. I 'PSOAUTO D
. . W !!,"Step 2: Copy the "_$S(PSOSTDIR'="":"four",1:"three")_" lines of text below into the clipboard (highlight the"
. . W !?8,"lines then right-click the mouse and select 'Copy').",!
. . W:$G(PSOSTDIR)'="" !,"cd "_PSOSTDIR
. . W !,"put "_$S(PSOOS["VMS":$$XVMSDIR^PSOSPMU1(LOCDIR),1:LOCDIR)_EXPFILE
. . W:$G(RENAME) !,"rename "_EXPFILE_" "_$P(EXPFILE,".up",1)_PSOFLEXT
. . W !,"exit",!
. . K DIR,DTOUT,DUOUT S DIR(0)="E",DIR("A")="Then press <RETURN> to go to the next step." D ^DIR I $G(DTOUT)!$G(DUOUT) Q
. . W !!,"Step 3: Enter the sFTP password and press <RETURN>"
. . W !!,"Step 4: Once you get the 'sftp>' prompt, paste the text copied on step 2"
. . W !?8,"(right-click the mouse and select 'Paste').",!!
. . N XPV1,PV S XPV1="S PV=$ZF(-1,""sftp"_$S(PSOPORT:" -oPort="_PSOPORT,1:"")_" -oUser="_$TR(PSOSTUSR,"""","")_" "_PSOSTIP_""")"
. . X XPV1
. I $P(PSOFTPOK,"^",1)=-1 D LOGERROR(BATCHIEN,0,$P(PSOFTPOK,"^",2),BCKGRND,$G(LOGFILE))
. ;Deleting files
. D DELFILES^PSOSPMU1($G(LOCDIR),$G(EXPFILE),$G(INPTFILE),$G(FTPFILE),$G(LOGFILE))
. I $P(PSOFTPOK,"^",1)=-1 Q
. I 'PSOAUTO,$G(DTOUT)!$G(DUOUT) Q
. I 'BCKGRND,PSOAUTO H 1 W !!,"File Successfully Transmitted.",!
. I 'PSOAUTO D I $G(DTOUT)!$G(DUOUT)!'Y Q
. . K DIR S DIR("A")="Was the file transmitted successfully",DIR(0)="Y",DIR("B")="N"
. . D ^DIR
. S DIE="^PS(58.42,",DA=BATCHIEN,DR="6///"_EXPFILE2_";7////"_DUZ_";9///"_$$NOW^XLFDT() D ^DIE
W ! L -@("PMP"_DATETIME)
Q
;
WRITELEV(LEVEL,ARRAY) ; Write the ASAP Segments for each Level
;Input: LEVEL - ASAP level to print (1:Header, 2:Pharmacy, ...)
; ARRAY - Name of the Array containing the ASAP Data Definition (e.g., "ASAP")
N NODE,SEGID,SEG0
S NODE=ARRAY
F S NODE=$Q(@NODE) Q:NODE=""!($E(NODE,$F(NODE,"("))'?1N) D
. S SEGID=@NODE I SEGID="" Q
. S SEG0=$G(@(ARRAY_"("""_SEGID_""")"))
. ; Segment not in the Level
. I $P(SEG0,"^",6)'=LEVEL Q
. ; Segment Marked NOT USED
. I $P(SEG0,"^",4)="N" Q
. D WRITESEG(SEGID,LEVEL,ARRAY)
Q
;
WRITESEG(SEGID,LEVEL,ARRAY) ; Write the ASAP segment to the file
;Input: SEGID - ASAP Segment ID (e.g., "TH", "PAT", "DSP", ...)
; LEVEL - ASAP level to print (1:Header, 2:Pharmacy, ...)
; ARRAY - Name of the Array containing the ASAP Data Definition (e.g., "ASAP")
N ELMPOS,LASTELEM
I '$D(@ARRAY@(SEGID)) Q
I $G(MODE)="VIEW",$P(@ARRAY,"^",4)'="" W ?$S(LEVEL<5:((LEVEL-1)*3),LEVEL=5:3,1:0)
S LASTELEM=+$O(@ARRAY@(SEGID,""),-1)
W SEGID D SEGCOUNT(LEVEL)
F ELMPOS=1:1:LASTELEM D
. ;Skipping Last Element if marked NOT USED (to solve issue with TH09 for 4.0 and TH13 for 3.0)
. I (+$G(PSOASVER)<4.2)!((+$G(PSOASVER)=4.2)&($E(PSOASVER,1,4)'="4.2A")&($E(PSOASVER,1,4)'="4.2B")) I ELMPOS=LASTELEM,$P(@ARRAY@(SEGID,ELMPOS),"^",6)="N" Q ; 772
. ;Data Element Delimiter Char
. W $P(@ARRAY,"^",2)
. ; ASAP Data Element Marked NOT USED
. I $P(@ARRAY@(SEGID,ELMPOS),"^",6)="N" Q
. ; Writing Data Element Content to the file
. D WRITEELM(SEGID,ELMPOS,ARRAY)
; Segment Terminator Character
W $P(@ARRAY,"^",3)
; End of Segment Control Char(s) (e.g., Line-Feed ($C(10)), Carriage-Return ($C(13)),etc.)
W:$P(@ARRAY,"^",4)'="" @($P(@ARRAY,"^",4))
Q
;
WRITEELM(SEGID,ELMPOS,ARRAY) ; Write the ASAP Data Element to file
;Input: SEGID - ASAP Segment ID (e.g., "TH", "PAT", "DSP", ...)
; ELMPOS - ASAP Data Element Position (1, 2, 3, ...)
; ARRAY - Name of the Array containing the ASAP Data Definition (e.g., "ASAP")
N MEXPR,GETVALUE,VALUE,MAXLEN
S MEXPR=$G(@ARRAY@(SEGID,ELMPOS,"VAL",1))
; Rechecking the M Expression value for Security purposes
I '$$VALID^PSOSPMU3($P(@ARRAY,"^"),MEXPR) W "?" Q
; Retrieving and executing the M code for retrieving the ASAP Data Element value
D
. N $ETRAP,$ESTACK S $ETRAP="D ERROR^PSOSPMUT"
. S GETVALUE="S VALUE="_MEXPR X GETVALUE
; Removing Control Characters from the Data Element Value
S VALUE=$$ESC(VALUE)
; Triming Value according to the Data Element Maximum Length
S MAXLEN=$P($G(@ARRAY@(SEGID,ELMPOS)),"^",4) S:MAXLEN>0 VALUE=$E(VALUE,1,MAXLEN)
; Replacing characters that match Segment Delimiter chars with "?"
I MAXLEN>1,VALUE'=$P(@ARRAY,"^",3) S VALUE=$TR(VALUE,$P(@ARRAY,"^",3),"?")
; Replacing characters that match Data Element Delimiter chars with "?"
I MAXLEN>1,VALUE'=$P(@ARRAY,"^",2) S VALUE=$TR(VALUE,$P(@ARRAY,"^",2),"?")
; Writing the Data Element Value
W VALUE
Q
;
SEGCOUNT(LEVEL) ; Keeps track of Segment Count for TP and TT info
;Input: LEVEL - Level of the Segment where the Data Element is located
; TT Segment Count
S PSOTTCNT=$G(PSOTTCNT)+1
; TP Segment Count
I LEVEL'=1,LEVEL'=6 S PSOTPCNT=$G(PSOTPCNT)+1
Q
;
ERROR ; Error Trap Handling to catch errors on user-entered M SET expressions
N ERROR
D CLOSE^%ZISH("EXPFILE")
S ERROR="ASAP Data Element: "_$G(SEGID)_$E(100+$G(ELMPOS),2,3)_" M Expression: "_$G(MEXPR)_" Error: "_$$EC^%ZOSV
D LOGERROR($G(BATCHIEN),0,ERROR,$G(BCKGRND))
D DELFILES^PSOSPMU1($G(LOCDIR),$G(EXPFILE),$G(INPTFILE),$G(FTPFILE))
Q
;
SCREEN(RXIEN,FILLNUM) ; Screens Rx's from being sent to the State
; Input: RXIEN - PRESCRIPTION file (#52) IEN
; FILLNUM - Fill Number
;Output: $$SCREEN - 1:YES/0:NO^Error/Warning Message^E:Error/W:Warning
;
; Not a Controlled Substance
I '$$CSRX(RXIEN) Q "1^"_$$GET1^DIQ(52,RXIEN,6)_" is not a Controlled Substance Drug.^E"
;
; Fills Administered in Clinic exclusion
I $$ADMCLN(RXIEN,FILLNUM) Q "1^Prescription fill was administered in clinic.^E"
;
; Released prior to Transmission Authorization Date (02/11/2013)
I $$RXRLDT^PSOBPSUT(RXIEN,FILLNUM),$$RXRLDT^PSOBPSUT(RXIEN,FILLNUM)<3130211 Q "1^Prescription fill released before 02/11/2013.^E"
;
; Non-Veteran Patient Exclusion (Based on parameter)
N STATE,DFN,VAEL
S STATE=$$RXSTATE^PSOBPSUT(RXIEN,0)
I '$$GET1^DIQ(58.41,STATE,2,"I") D I '$G(VAEL(4)) Q "1^Patient "_$$GET1^DIQ(52,RXIEN,2)_" is not a Veteran.^E"
. S DFN=$$GET1^DIQ(52,RXIEN,2,"I") D ELIG^VADPT
;
Q 0
;
CSRX(RXIEN) ; Controlled Substance Rx?
; Input: RXIEN - PRESCRIPTION file (#52) pointer
;Output: $$CS - 1:YES / 0:NO
N DRGIEN,DEA
S DRGIEN=$$GET1^DIQ(52,RXIEN,6,"I") I 'DRGIEN Q 0
S DEA=$$GET1^DIQ(50,DRGIEN,3)
I (DEA'["0"),(DEA'["M"),(DEA["2")!(DEA["3")!(DEA["4")!(DEA["5") Q 1
Q 0
;
ADMCLN(RXIEN,FILL) ; Returns whether the fill was administered in clinic or not
; Input: (r) RXIEN - Rx IEN (#52)
; (o) FILL - Refill #
; Output: 1 - Yes (Administered in Clinic) / 0 - No
N ADMCLN
I '$G(RXIEN) Q 0
I 'FILL S ADMCLN=+$$GET1^DIQ(52,RXIEN,14,"I")
I FILL S ADMCLN=+$$GET1^DIQ(52.1,FILL_","_RXIEN,23,"I")
Q ADMCLN
;
SPOK(STATE) ; State Parameters OK?
; Input: STATE - STATE file (#5) pointer
N ZNODE,FNODE,F1NODE,X,STATENAM
S STATENAM=$$GET1^DIQ(5,+$G(STATE),.01)
I '$D(^PS(58.41,+$G(STATE),0)) Q "-1^PMP parameters missing for "_STATENAM
S ZNODE=$G(^PS(58.41,STATE,0))
I $P(ZNODE,"^",2)="" Q "-1^ASAP Version missing for "_STATENAM
I $P(ZNODE,"^",4)="" Q "-1^Reporting Frequency missing for "_STATENAM
S FNODE=$G(^PS(58.41,STATE,"FILE"))
S F1NODE=$G(^PS(58.41,STATE,"FILE1"))
I $$OS^%ZOSV()["VMS",$P(FNODE,"^",1)="" Q "-1^Local VMS Directory missing for "_STATENAM
I $$OS^%ZOSV()["UNIX",$P(F1NODE,"^",1)="" Q "-1^Local Unix/Linux Directory missing for "_STATENAM
I $P(FNODE,"^",4)="" Q "-1^State FTP Server IP Address missing for "_STATENAM
I $P(FNODE,"^",5)="" Q "-1^State FTP Server username missing for "_STATENAM
I $P(ZNODE,"^",6)="A",'$O(^PS(58.41,STATE,"PRVKEY",0)) Q "-1^SSH Keys missing for "_STATENAM
Q 1
;
SETNAME(DFN) ; Set array variable PSONAME with Patient name
N NCIEN K PSONAME
S NCIEN=$$GET1^DIQ(2,DFN,1.01,"I")
I NCIEN,$$GET1^DIQ(20,NCIEN,1)'="",$$GET1^DIQ(20,NCIEN,2)'="" D Q
. S PSONAME("LAST")=$$GET1^DIQ(20,NCIEN,1)
. S PSONAME("FIRST")=$$GET1^DIQ(20,NCIEN,2)
. S PSONAME("MIDDLE")=$$GET1^DIQ(20,NCIEN,3)
. S PSONAME("PREFIX")=$$GET1^DIQ(20,NCIEN,4)
. S PSONAME("SUFFIX")=$$GET1^DIQ(20,NCIEN,5)
;
S PSONAME("LAST")=$P($G(VADM(1)),",",1)
S PSONAME("FIRST")=$P($P($G(VADM(1)),",",2)," ",1)
S PSONAME("MIDDLE")=$P($P($G(VADM(1)),",",2)," ",2)
S PSONAME("SUFFIX")=""
S PSONAME("PREFIX")=""
Q
;
LOGERROR(BATCHIEN,STATEIEN,ERROR,BCKGRND,LOGFILE) ; Log/Display an error in the transmission
;Input: (r) BATCHIEN - Pointer to the SPMP EXPORT BATCH file (#58.42)
; (r) STATEIEN - Pointer ot the STATE file (#5)
; (r) ERROR - Error Text
; (r) BCKGRND - Background execution (1: Yes / 0: No)
; (o) LOGFILE - Filename of the file containing the sFTP Log (VMS only)
I '$G(BCKGRND) W !!,ERROR,!,$C(7) Q
;
;Builds mail message and sends it to users of PSO SPMP NOTIFICATIONS mail group
N XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ,PSOMSG,USR,STANAME,LINE
;
S STANAME=$S($G(BATCHIEN):$$GET1^DIQ(58.42,BATCHIEN,1),1:$$GET1^DIQ(5,STATEIEN,.01))
S XMSUB=STANAME_" Prescription Monitoring Program Transmission Failed"
S XMDUZ="SPMP TRANSMISSION"
S PSOMSG(1)="There was a problem with the transmission of information about Controlled"
S PSOMSG(2)="Substance prescriptions to the "_STANAME_" State Prescription Monitoring"
s PSOMSG(3)="Program (SPMP)."
S PSOMSG(4)="",LINE=5
I $G(BATCHIEN) D
. S PSOMSG(LINE)="Batch #: "_BATCHIEN,LINE=LINE+1
. I $$GET1^DIQ(58.42,BATCHIEN,4,"I") D
. . S PSOMSG(LINE)="Period : "_$$FMTE^XLFDT($$GET1^DIQ(58.42,BATCHIEN,4,"I")\1,"2Z")
. . S PSOMSG(LINE)=PSOMSG(LINE)_" thru "_$$FMTE^XLFDT($$GET1^DIQ(58.42,BATCHIEN,5,"I")\1,"2Z"),LINE=LINE+1
. S PSOMSG(LINE)="Error : "_ERROR,LINE=LINE+1
. S PSOMSG(LINE)="",LINE=LINE+1
. S PSOMSG(LINE)="Please, use the option Export Batch Processing [PSO SPMP BATCH PROCESSING] to",LINE=LINE+1
. S PSOMSG(LINE)="manually transmit this batch to the state.",LINE=LINE+1
E S PSOMSG(LINE)="Error : "_ERROR,LINE=LINE+1
S XMTEXT="PSOMSG("
;
; Loading the VMS Log into the Mailman Message
I $G(LOGFILE)'="" D
. N LOCDIR,FILEARR,LOG,XLOG
. S LOCDIR=$$GET1^DIQ(58.41,+$$GET1^DIQ(58.42,BATCHIEN,1,"I"),$S($$OS^%ZOSV()["VMS":4,1:15)) I LOCDIR="" Q
. I '$$FEXIST(LOCDIR,LOGFILE) Q
. S PSOMSG(LINE)="",LINE=LINE+1
. S PSOMSG(LINE)="sFTP Log:",LINE=LINE+1
. S PSOMSG(LINE)="========",LINE=LINE+1
. K ^TMP("PSOFTPLG",$J)
. S XLOG=$$FTG^%ZISH(LOCDIR,LOGFILE,$NAME(^TMP("PSOFTPLG",$J,1)),3)
. S LOG=0 F S LOG=$O(^TMP("PSOFTPLG",$J,LOG)) Q:LOG="" D
. . S PSOMSG(LINE)=$G(^TMP("PSOFTPLG",$J,LOG)),LINE=LINE+1
;
; If there are no active members in the mailgroup sends message to PSDMGR key holders
I $$GOTLOCAL^XMXAPIG("PSO SPMP NOTIFICATIONS") D
. S XMY("G.PSO SPMP NOTIFICATIONS")=""
E D
. S USR=0 F S USR=$O(^XUSEC("PSDMGR",USR)) Q:'USR S XMY(USR)=""
D ^XMD
Q
;
PREIEN(RECTYPE,RXIEN,FILLNUM) ; Returns the Provider IEN
;Input: RECTYPE - Record Type ('S': SEND, 'R': REVIEW, 'V': VOID)
; RXIEN - PRESCRIPTION file (#52) IEN
; FILLNUM - Fill Number
Q +$S(RECTYPE="V"&($G(RTSDATA("PRVIEN"))):RTSDATA("PRVIEN"),1:$$RXPRV^PSOBPSUT(RXIEN,FILLNUM))
;
RPHIEN(RECTYPE,RXIEN,FILLNUM) ; Returns the Pharmacist IEN
;Input: RECTYPE - Record Type ('S': SEND, 'R': REVIEW, 'V': VOID)
; RXIEN - PRESCRIPTION file (#52) IEN
; FILLNUM - Fill Number
Q +$S(RECTYPE="V"&($G(RTSDATA("RPHIEN"))):RTSDATA("RPHIEN"),1:$$RXRPH^PSOBPSUT(RXIEN,FILLNUM))
;
FEXIST(DIR,FILE) ; Check if a File exists
; Input: DIR - Name of the directory where the file is located
; FILE - Name of the file to be checked
;Output: $$FEXIST - 1 - File Exists / 0 - File Not Found
N RETURN,FILEARR
S FILEARR(FILE)=""
Q +$$LIST^%ZISH(DIR,"FILEARR","RETURN")
;
ESC(VALUE) ; Removes Control Characters from the Data Element Value
N ESCVALUE,I
S ESCVALUE=""
F I=1:1:$L(VALUE) I $A(VALUE,I)>31,$A(VALUE,I)<127 S ESCVALUE=ESCVALUE_$E(VALUE,I)
Q ESCVALUE
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOSPMUT 19521 printed Sep 23, 2025@20:11:41 Page 2
PSOSPMUT ;BIRM/MFR - State Prescription Monitoring Program Utilities ;10/07/12
+1 ;;7.0;OUTPATIENT PHARMACY;**408,451,549,625,630,772**;DEC 1997;Build 105
+2 ;
EXPORT(BATCHIEN,MODE,BCKGRND,DEBUG,FLUSH) ; Export a SPMP Batch
+1 ;Input: BATCHIEN - Pointer to #58.41
+2 ; MODE - "VIEW" or "EXPORT"
+3 ; BCKGRND - Background? (1:YES / 0:NO)
+4 ; DEBUG - Debug Mode? (1:YES / 0:NO)
+5 ; FLUSH - Flush host? (1:YES / 0:NO)
+6 NEW X,RX,STATEIEN,PSOASVER,TRXTYPE,PSOTTCNT,PSOTPCNT,SITEIEN,RXIEN,FILLNUM,FILLIEN,PATIEN,DFN,VADM
+7 NEW RTSDATA,DATETIME,VAPA,XX,ASAP,LOCDIR,EXPFILE,EXPFILE2,FTPFILE,INPTFILE,DIE,DR,DA,PSOFTPOK,FILES
+8 NEW PSODELOK,PSOOS,RTSONLY,PSOSTIP,PSOSTUSR,PSONAME,PSOPORT,PSOAUTO,PSOSTDIR,PSOFLEXT,RENAME,DRUGIEN
+9 NEW PREIEN,RPHIEN,RTSREC,RXNODE,ZRS,ZRNODE,DEA,PSOVER
+10 SET BCKGRND=+$GET(BCKGRND)
SET DEBUG=+$GET(DEBUG)
SET FLUSH=+$GET(FLUSH)
KILL ^TMP("PSOSPMEX",$JOB),ZRDEA
+11 ;
+12 IF +$$SPOK($$GET1^DIQ(58.42,BATCHIEN,1,"I"))=-1
Begin DoDot:1
+13 DO LOGERROR(BATCHIEN,0,$PIECE($$SPOK($$GET1^DIQ(58.42,BATCHIEN,1,"I")),"^",2),BCKGRND)
End DoDot:1
QUIT
+14 ;
+15 ; The LOCK below prevents two concurrent transmission processes from getting the same filename
+16 FOR
SET DATETIME=$PIECE($$FMTHL7^XLFDT($$HTFM^XLFDT($HOROLOG)),"-")
LOCK +@("PMP"_DATETIME):0
if $TEST
QUIT
HANG 2
+17 ;
+18 SET STATEIEN=$$GET1^DIQ(58.42,BATCHIEN,1,"I")
+19 SET PSOASVER=$$GET1^DIQ(58.41,STATEIEN,1,"I")
+20 ;Zero Reporting
IF $$GET1^DIQ(58.42,BATCHIEN,2,"I")="ZR"
SET PSOASVER=$$GET1^DIQ(58.41,STATEIEN,20)
+21 SET PSOFLEXT=$$GET1^DIQ(58.41,STATEIEN,6)
+22 SET RENAME=$$GET1^DIQ(58.41,STATEIEN,17,"I")
+23 SET PSOSTIP=$$GET1^DIQ(58.41,STATEIEN,7)
+24 SET PSOPORT=$$GET1^DIQ(58.41,STATEIEN,9)
+25 ;
+26 ; The commands below will first 'flush' and then add the IP Address to the known_hosts file
+27 SET PSOVER=$$UP^XLFSTR($$VERSION^%ZOSV(1))
+28 ;PSO*7*630
IF MODE="EXPORT"
IF $$OS^%ZOSV()="UNIX"
IF (PSOVER["CACHE")!(PSOVER["IRIS")
Begin DoDot:1
+29 IF DEBUG
IF FLUSH
XECUTE "S PV=$ZF(-1,""ssh-keygen -R ""_PSOSTIP)"
+30 XECUTE "S PV=$ZF(-1,""ssh -oBatchMode=yes -oStrictHostKeyChecking=no -oLogLevel=quiet"_$SELECT(PSOPORT:" -oPort="_PSOPORT,1:"")_" "_PSOSTIP_""")"
End DoDot:1
+31 ;
+32 SET PSOSTUSR=$$GET1^DIQ(58.41,STATEIEN,8)
+33 SET PSOSTDIR=$$GET1^DIQ(58.41,STATEIEN,10)
+34 SET PSOAUTO=$SELECT($$GET1^DIQ(58.41,STATEIEN,13,"I")="A":1,1:0)
+35 SET PSOOS=$$OS^%ZOSV()
+36 ;
+37 IF MODE="EXPORT"
IF '$GET(BCKGRND)
WRITE !!,"Exporting Batch #",BATCHIEN,":",!
+38 ;
+39 SET RX=0
+40 FOR
SET RX=$ORDER(^PS(58.42,BATCHIEN,"RX",RX))
if 'RX
QUIT
Begin DoDot:1
+41 SET RXNODE=^PS(58.42,BATCHIEN,"RX",RX,0)
+42 SET RXIEN=+RXNODE
SET FILLNUM=$PIECE(RXNODE,"^",2)
SET PATIEN=$$GET1^DIQ(52,RXIEN,2,"I")
+43 IF MODE="EXPORT"
IF $PIECE(RXNODE,"^",3)'="V"
IF '$$RXRLDT^PSOBPSUT(RXIEN,FILLNUM)
QUIT
+44 ; PSO*7*625:PSU-14 - Allow VOID Export of Released Prescriptions in RX Batch Only
+45 ; PSO*7*625:PSU-14
IF MODE="EXPORT"
IF $PIECE(RXNODE,"^",3)="V"
IF $$RXRLDT^PSOBPSUT(RXIEN,FILLNUM)
IF ($$GET1^DIQ(58.42,BATCHIEN,2,"I")'="RX")
QUIT
+46 ; Always the Pharmacy Division for the Original Fill
+47 SET SITEIEN=$$RXSITE^PSOBPSUT(RXIEN,0)
+48 SET ^TMP("PSOSPMEX",$JOB,SITEIEN,PATIEN,RXIEN,FILLNUM)=$PIECE(RXNODE,"^",3)
End DoDot:1
+49 ;
+50 ;Zero report
IF $$GET1^DIQ(58.41,STATEIEN,20)'=""
IF $$GET1^DIQ(58.42,BATCHIEN,2,"I")="ZR"
Begin DoDot:1
+51 SET ZRS=0
SET SITEIEN=""
+52 FOR
SET ZRS=$ORDER(^PS(58.42,BATCHIEN,"ZRS",ZRS))
if 'ZRS
QUIT
Begin DoDot:2
+53 SET ZRNODE=^PS(58.42,BATCHIEN,"ZRS",ZRS,0)
+54 SET SITEIEN=+ZRNODE
SET DEA=$PIECE(ZRNODE,"^",2)
+55 SET ZRDEA(DEA)=SITEIEN
End DoDot:2
+56 NEW DEA
SET (DEA,SITEIEN)=""
+57 FOR
SET DEA=$ORDER(ZRDEA(DEA))
if DEA=""
QUIT
Begin DoDot:2
+58 SET SITEIEN=ZRDEA(DEA)
SET ^TMP("PSOSPMEX",$JOB,SITEIEN)=""
End DoDot:2
End DoDot:1
+59 ;
+60 IF '$DATA(^TMP("PSOSPMEX",$JOB))
Begin DoDot:1
+61 DO LOGERROR(BATCHIEN,0,"There were no eligible prescriptions in the batch #"_BATCHIEN,BCKGRND)
End DoDot:1
LOCK -@("PMP"_DATETIME)
QUIT
+62 ;
+63 IF MODE="VIEW"
IF PSOASVER'="1995"
SET XX=""
SET $PIECE(XX,"-",80)=""
WRITE !,XX,!
+64 IF MODE="EXPORT"
Begin DoDot:1
+65 SET RTSONLY=0
IF $$GET1^DIQ(58.42,BATCHIEN,2,"I")="VD"
SET RTSONLY=1
+66 IF PSOOS["VMS"
SET LOCDIR=$$GET1^DIQ(58.41,STATEIEN,4)
+67 IF PSOOS["UNIX"
Begin DoDot:2
+68 SET LOCDIR=$$GET1^DIQ(58.41,STATEIEN,15)
+69 IF '$$DIREXIST^PSOSPMU1(LOCDIR)
DO MAKEDIR^PSOSPMU1(LOCDIR)
End DoDot:2
+70 SET FILES=$$PREPFILE^PSOSPMU1(STATEIEN,DATETIME,RTSONLY,DEBUG)
+71 IF $PIECE(FILES,"^",1)=-1
DO LOGERROR(BATCHIEN,0,$PIECE(FILES,"^",2),BCKGRND)
QUIT
+72 SET EXPFILE=$PIECE(FILES,"^",2)
+73 SET FTPFILE=$PIECE(FILES,"^",3)
+74 SET INPTFILE=$PIECE(FILES,"^",4)
+75 SET LOGFILE=$PIECE(FILES,"^",5)
+76 SET EXPFILE2=$PIECE(FILES,"^",6)
+77 IF 'BCKGRND
WRITE !,$SELECT('PSOAUTO:"Step 1: ",1:""),"Writing to file ",LOCDIR_EXPFILE,"..."
+78 DO OPEN^%ZISH("EXPFILE",LOCDIR,EXPFILE,"W")
+79 IF POP
DO LOGERROR(BATCHIEN,0,"Export File <"_LOCDIR_EXPFILE_"> could not be created.",BCKGRND)
SET FILES=-1
QUIT
+80 DO USE^%ZISUTL("EXPFILE")
End DoDot:1
IF $PIECE(FILES,"^",1)=-1
LOCK -@("PMP"_DATETIME)
QUIT
+81 ;----------------------------- ASAP Data Output (1995) -------------------------------
+82 IF PSOASVER="1995"
Begin DoDot:1
+83 SET (SITEIEN,PATIEN,RXIEN)=0
+84 FOR
SET SITEIEN=$ORDER(^TMP("PSOSPMEX",$JOB,SITEIEN))
if 'SITEIEN
QUIT
Begin DoDot:2
+85 FOR
SET PATIEN=$ORDER(^TMP("PSOSPMEX",$JOB,SITEIEN,PATIEN))
if 'PATIEN
QUIT
Begin DoDot:3
+86 KILL VADM,VAPA,PSONAME
SET DFN=PATIEN
DO DEM^VADPT
DO ADD^VADPT
DO SETNAME(PATIEN)
+87 FOR
SET RXIEN=$ORDER(^TMP("PSOSPMEX",$JOB,SITEIEN,PATIEN,RXIEN))
if 'RXIEN
QUIT
Begin DoDot:4
+88 SET FILLNUM=""
+89 FOR
SET FILLNUM=$ORDER(^TMP("PSOSPMEX",$JOB,SITEIEN,PATIEN,RXIEN,FILLNUM))
if FILLNUM=""
QUIT
Begin DoDot:5
+90 SET RECTYPE=^TMP("PSOSPMEX",$JOB,SITEIEN,PATIEN,RXIEN,FILLNUM)
+91 KILL RTSDATA
IF RECTYPE="V"
DO LOADRTS^PSOSPMU1(RXIEN,FILLNUM,.RTSDATA)
+92 WRITE $$ASAP95^PSOASAP0(RXIEN,+FILLNUM),!
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+93 ;------------------------- ASAP Data Output (3.0 and above) --------------------------
+94 IF PSOASVER'="1995"
Begin DoDot:1
+95 SET TRXTYPE="S"
SET PSOTTCNT=0
+96 DO LOADASAP^PSOSPMU0(PSOASVER,"B",.ASAP)
+97 SET (SITEIEN,PATIEN,RXIEN)=0
+98 ;Writing Level 1: Transaction Header, Information Source
+99 DO WRITELEV(1,"ASAP")
+100 FOR
SET SITEIEN=$ORDER(^TMP("PSOSPMEX",$JOB,SITEIEN))
if 'SITEIEN
QUIT
Begin DoDot:2
+101 SET PSOTPCNT=0
+102 ;Writing Level 2: Pharmacy Header
+103 DO WRITELEV(2,"ASAP")
+104 ;Zero Reporting
+105 IF $$GET1^DIQ(58.42,BATCHIEN,2,"I")="ZR"
Begin DoDot:3
+106 ;Zero Reporting Writing Level 3: Patient Detail
+107 DO WRITELEV(3,"ASAP")
+108 ;Zero Reporting Writing Level 4: Prescription Detail
+109 DO WRITELEV(4,"ASAP")
End DoDot:3
+110 FOR
SET PATIEN=$ORDER(^TMP("PSOSPMEX",$JOB,SITEIEN,PATIEN))
if 'PATIEN
QUIT
Begin DoDot:3
+111 KILL VADM,VAPA,PSONAME
SET DFN=PATIEN
DO DEM^VADPT
DO ADD^VADPT
DO SETNAME(PATIEN)
+112 SET (DRUGIEN,FILLNUM,FILLIEN,PREIEN,RPHIEN,RTSREC)=0
+113 ;Writing Level 3: Patient Detail
+114 DO WRITELEV(3,"ASAP")
+115 FOR
SET RXIEN=$ORDER(^TMP("PSOSPMEX",$JOB,SITEIEN,PATIEN,RXIEN))
if 'RXIEN
QUIT
Begin DoDot:4
+116 SET FILLNUM=""
SET DRUGIEN=$$GET1^DIQ(52,RXIEN,6,"I")
+117 FOR
SET FILLNUM=$ORDER(^TMP("PSOSPMEX",$JOB,SITEIEN,PATIEN,RXIEN,FILLNUM))
if FILLNUM=""
QUIT
Begin DoDot:5
+118 SET FILLIEN=$SELECT(FILLNUM["P":+$PIECE(FILLNUM,"P",2),1:+FILLNUM)
+119 SET RECTYPE=^TMP("PSOSPMEX",$JOB,SITEIEN,PATIEN,RXIEN,FILLNUM)
+120 SET PREIEN=$$PREIEN(RECTYPE,RXIEN,FILLNUM)
+121 SET RPHIEN=$$RPHIEN(RECTYPE,RXIEN,FILLNUM)
+122 SET RTSREC=0
KILL RTSDATA
IF RECTYPE="V"
SET RTSREC=1
DO LOADRTS^PSOSPMU1(RXIEN,FILLNUM,.RTSDATA)
+123 ;Writing Level 4: Prescription Detail
+124 DO WRITELEV(4,"ASAP")
End DoDot:5
End DoDot:4
End DoDot:3
+125 ;Writing Level 5: Pharmacy Trailer
+126 DO WRITELEV(5,"ASAP")
End DoDot:2
+127 ;Writing Level 6: Transaction Trailer
+128 DO WRITELEV(6,"ASAP")
End DoDot:1
+129 ; Close the file
+130 IF MODE="EXPORT"
DO CLOSE^%ZISH("EXPFILE")
IF 'BCKGRND
WRITE "Done."
+131 ;------------------------- sFTP Transmission to the State -----------------------------
+132 IF MODE="VIEW"
IF PSOASVER'="1995"
SET XX=""
SET $PIECE(XX,"-",80)=""
WRITE !,XX
+133 SET (PSOFTPOK,PSODELOK)=""
+134 IF MODE="EXPORT"
Begin DoDot:1
+135 ; Automated Transmission (RSA keys)
+136 IF PSOAUTO
Begin DoDot:2
+137 IF 'BCKGRND
WRITE !!,"Transmitting file to the State (",$$GET1^DIQ(58.41,STATEIEN,7),")...",!
+138 SET PSOFTPOK=$$FTPFILE^PSOSPMU1(PSOSTIP,PSOSTUSR,LOCDIR,FTPFILE,EXPFILE,INPTFILE,LOGFILE,PSOPORT,DEBUG)
End DoDot:2
+139 ; Manual Transmission (Password)
+140 KILL DTOUT,DUOUT
+141 IF 'PSOAUTO
Begin DoDot:2
+142 WRITE !!,"Step 2: Copy the "_$SELECT(PSOSTDIR'="":"four",1:"three")_" lines of text below into the clipboard (highlight the"
+143 WRITE !?8,"lines then right-click the mouse and select 'Copy').",!
+144 if $GET(PSOSTDIR)'=""
WRITE !,"cd "_PSOSTDIR
+145 WRITE !,"put "_$SELECT(PSOOS["VMS":$$XVMSDIR^PSOSPMU1(LOCDIR),1:LOCDIR)_EXPFILE
+146 if $GET(RENAME)
WRITE !,"rename "_EXPFILE_" "_$PIECE(EXPFILE,".up",1)_PSOFLEXT
+147 WRITE !,"exit",!
+148 KILL DIR,DTOUT,DUOUT
SET DIR(0)="E"
SET DIR("A")="Then press <RETURN> to go to the next step."
DO ^DIR
IF $GET(DTOUT)!$GET(DUOUT)
QUIT
+149 WRITE !!,"Step 3: Enter the sFTP password and press <RETURN>"
+150 WRITE !!,"Step 4: Once you get the 'sftp>' prompt, paste the text copied on step 2"
+151 WRITE !?8,"(right-click the mouse and select 'Paste').",!!
+152 NEW XPV1,PV
SET XPV1="S PV=$ZF(-1,""sftp"_$SELECT(PSOPORT:" -oPort="_PSOPORT,1:"")_" -oUser="_$TRANSLATE(PSOSTUSR,"""","")_" "_PSOSTIP_""")"
+153 XECUTE XPV1
End DoDot:2
+154 IF $PIECE(PSOFTPOK,"^",1)=-1
DO LOGERROR(BATCHIEN,0,$PIECE(PSOFTPOK,"^",2),BCKGRND,$GET(LOGFILE))
+155 ;Deleting files
+156 DO DELFILES^PSOSPMU1($GET(LOCDIR),$GET(EXPFILE),$GET(INPTFILE),$GET(FTPFILE),$GET(LOGFILE))
+157 IF $PIECE(PSOFTPOK,"^",1)=-1
QUIT
+158 IF 'PSOAUTO
IF $GET(DTOUT)!$GET(DUOUT)
QUIT
+159 IF 'BCKGRND
IF PSOAUTO
HANG 1
WRITE !!,"File Successfully Transmitted.",!
+160 IF 'PSOAUTO
Begin DoDot:2
+161 KILL DIR
SET DIR("A")="Was the file transmitted successfully"
SET DIR(0)="Y"
SET DIR("B")="N"
+162 DO ^DIR
End DoDot:2
IF $GET(DTOUT)!$GET(DUOUT)!'Y
QUIT
+163 SET DIE="^PS(58.42,"
SET DA=BATCHIEN
SET DR="6///"_EXPFILE2_";7////"_DUZ_";9///"_$$NOW^XLFDT()
DO ^DIE
End DoDot:1
+164 WRITE !
LOCK -@("PMP"_DATETIME)
+165 QUIT
+166 ;
WRITELEV(LEVEL,ARRAY) ; Write the ASAP Segments for each Level
+1 ;Input: LEVEL - ASAP level to print (1:Header, 2:Pharmacy, ...)
+2 ; ARRAY - Name of the Array containing the ASAP Data Definition (e.g., "ASAP")
+3 NEW NODE,SEGID,SEG0
+4 SET NODE=ARRAY
+5 FOR
SET NODE=$QUERY(@NODE)
if NODE=""!($EXTRACT(NODE,$FIND(NODE,"("))'?1N)
QUIT
Begin DoDot:1
+6 SET SEGID=@NODE
IF SEGID=""
QUIT
+7 SET SEG0=$GET(@(ARRAY_"("""_SEGID_""")"))
+8 ; Segment not in the Level
+9 IF $PIECE(SEG0,"^",6)'=LEVEL
QUIT
+10 ; Segment Marked NOT USED
+11 IF $PIECE(SEG0,"^",4)="N"
QUIT
+12 DO WRITESEG(SEGID,LEVEL,ARRAY)
End DoDot:1
+13 QUIT
+14 ;
WRITESEG(SEGID,LEVEL,ARRAY) ; Write the ASAP segment to the file
+1 ;Input: SEGID - ASAP Segment ID (e.g., "TH", "PAT", "DSP", ...)
+2 ; LEVEL - ASAP level to print (1:Header, 2:Pharmacy, ...)
+3 ; ARRAY - Name of the Array containing the ASAP Data Definition (e.g., "ASAP")
+4 NEW ELMPOS,LASTELEM
+5 IF '$DATA(@ARRAY@(SEGID))
QUIT
+6 IF $GET(MODE)="VIEW"
IF $PIECE(@ARRAY,"^",4)'=""
WRITE ?$SELECT(LEVEL<5:((LEVEL-1)*3),LEVEL=5:3,1:0)
+7 SET LASTELEM=+$ORDER(@ARRAY@(SEGID,""),-1)
+8 WRITE SEGID
DO SEGCOUNT(LEVEL)
+9 FOR ELMPOS=1:1:LASTELEM
Begin DoDot:1
+10 ;Skipping Last Element if marked NOT USED (to solve issue with TH09 for 4.0 and TH13 for 3.0)
+11 ; 772
IF (+$GET(PSOASVER)<4.2)!((+$GET(PSOASVER)=4.2)&($EXTRACT(PSOASVER,1,4)'="4.2A")&($EXTRACT(PSOASVER,1,4)'="4.2B"))
IF ELMPOS=LASTELEM
IF $PIECE(@ARRAY@(SEGID,ELMPOS),"^",6)="N"
QUIT
+12 ;Data Element Delimiter Char
+13 WRITE $PIECE(@ARRAY,"^",2)
+14 ; ASAP Data Element Marked NOT USED
+15 IF $PIECE(@ARRAY@(SEGID,ELMPOS),"^",6)="N"
QUIT
+16 ; Writing Data Element Content to the file
+17 DO WRITEELM(SEGID,ELMPOS,ARRAY)
End DoDot:1
+18 ; Segment Terminator Character
+19 WRITE $PIECE(@ARRAY,"^",3)
+20 ; End of Segment Control Char(s) (e.g., Line-Feed ($C(10)), Carriage-Return ($C(13)),etc.)
+21 if $PIECE(@ARRAY,"^",4)'=""
WRITE @($PIECE(@ARRAY,"^",4))
+22 QUIT
+23 ;
WRITEELM(SEGID,ELMPOS,ARRAY) ; Write the ASAP Data Element to file
+1 ;Input: SEGID - ASAP Segment ID (e.g., "TH", "PAT", "DSP", ...)
+2 ; ELMPOS - ASAP Data Element Position (1, 2, 3, ...)
+3 ; ARRAY - Name of the Array containing the ASAP Data Definition (e.g., "ASAP")
+4 NEW MEXPR,GETVALUE,VALUE,MAXLEN
+5 SET MEXPR=$GET(@ARRAY@(SEGID,ELMPOS,"VAL",1))
+6 ; Rechecking the M Expression value for Security purposes
+7 IF '$$VALID^PSOSPMU3($PIECE(@ARRAY,"^"),MEXPR)
WRITE "?"
QUIT
+8 ; Retrieving and executing the M code for retrieving the ASAP Data Element value
+9 Begin DoDot:1
+10 NEW $ETRAP,$ESTACK
SET $ETRAP="D ERROR^PSOSPMUT"
+11 SET GETVALUE="S VALUE="_MEXPR
XECUTE GETVALUE
End DoDot:1
+12 ; Removing Control Characters from the Data Element Value
+13 SET VALUE=$$ESC(VALUE)
+14 ; Triming Value according to the Data Element Maximum Length
+15 SET MAXLEN=$PIECE($GET(@ARRAY@(SEGID,ELMPOS)),"^",4)
if MAXLEN>0
SET VALUE=$EXTRACT(VALUE,1,MAXLEN)
+16 ; Replacing characters that match Segment Delimiter chars with "?"
+17 IF MAXLEN>1
IF VALUE'=$PIECE(@ARRAY,"^",3)
SET VALUE=$TRANSLATE(VALUE,$PIECE(@ARRAY,"^",3),"?")
+18 ; Replacing characters that match Data Element Delimiter chars with "?"
+19 IF MAXLEN>1
IF VALUE'=$PIECE(@ARRAY,"^",2)
SET VALUE=$TRANSLATE(VALUE,$PIECE(@ARRAY,"^",2),"?")
+20 ; Writing the Data Element Value
+21 WRITE VALUE
+22 QUIT
+23 ;
SEGCOUNT(LEVEL) ; Keeps track of Segment Count for TP and TT info
+1 ;Input: LEVEL - Level of the Segment where the Data Element is located
+2 ; TT Segment Count
+3 SET PSOTTCNT=$GET(PSOTTCNT)+1
+4 ; TP Segment Count
+5 IF LEVEL'=1
IF LEVEL'=6
SET PSOTPCNT=$GET(PSOTPCNT)+1
+6 QUIT
+7 ;
ERROR ; Error Trap Handling to catch errors on user-entered M SET expressions
+1 NEW ERROR
+2 DO CLOSE^%ZISH("EXPFILE")
+3 SET ERROR="ASAP Data Element: "_$GET(SEGID)_$EXTRACT(100+$GET(ELMPOS),2,3)_" M Expression: "_$GET(MEXPR)_" Error: "_$$EC^%ZOSV
+4 DO LOGERROR($GET(BATCHIEN),0,ERROR,$GET(BCKGRND))
+5 DO DELFILES^PSOSPMU1($GET(LOCDIR),$GET(EXPFILE),$GET(INPTFILE),$GET(FTPFILE))
+6 QUIT
+7 ;
SCREEN(RXIEN,FILLNUM) ; Screens Rx's from being sent to the State
+1 ; Input: RXIEN - PRESCRIPTION file (#52) IEN
+2 ; FILLNUM - Fill Number
+3 ;Output: $$SCREEN - 1:YES/0:NO^Error/Warning Message^E:Error/W:Warning
+4 ;
+5 ; Not a Controlled Substance
+6 IF '$$CSRX(RXIEN)
QUIT "1^"_$$GET1^DIQ(52,RXIEN,6)_" is not a Controlled Substance Drug.^E"
+7 ;
+8 ; Fills Administered in Clinic exclusion
+9 IF $$ADMCLN(RXIEN,FILLNUM)
QUIT "1^Prescription fill was administered in clinic.^E"
+10 ;
+11 ; Released prior to Transmission Authorization Date (02/11/2013)
+12 IF $$RXRLDT^PSOBPSUT(RXIEN,FILLNUM)
IF $$RXRLDT^PSOBPSUT(RXIEN,FILLNUM)<3130211
QUIT "1^Prescription fill released before 02/11/2013.^E"
+13 ;
+14 ; Non-Veteran Patient Exclusion (Based on parameter)
+15 NEW STATE,DFN,VAEL
+16 SET STATE=$$RXSTATE^PSOBPSUT(RXIEN,0)
+17 IF '$$GET1^DIQ(58.41,STATE,2,"I")
Begin DoDot:1
+18 SET DFN=$$GET1^DIQ(52,RXIEN,2,"I")
DO ELIG^VADPT
End DoDot:1
IF '$GET(VAEL(4))
QUIT "1^Patient "_$$GET1^DIQ(52,RXIEN,2)_" is not a Veteran.^E"
+19 ;
+20 QUIT 0
+21 ;
CSRX(RXIEN) ; Controlled Substance Rx?
+1 ; Input: RXIEN - PRESCRIPTION file (#52) pointer
+2 ;Output: $$CS - 1:YES / 0:NO
+3 NEW DRGIEN,DEA
+4 SET DRGIEN=$$GET1^DIQ(52,RXIEN,6,"I")
IF 'DRGIEN
QUIT 0
+5 SET DEA=$$GET1^DIQ(50,DRGIEN,3)
+6 IF (DEA'["0")
IF (DEA'["M")
IF (DEA["2")!(DEA["3")!(DEA["4")!(DEA["5")
QUIT 1
+7 QUIT 0
+8 ;
ADMCLN(RXIEN,FILL) ; Returns whether the fill was administered in clinic or not
+1 ; Input: (r) RXIEN - Rx IEN (#52)
+2 ; (o) FILL - Refill #
+3 ; Output: 1 - Yes (Administered in Clinic) / 0 - No
+4 NEW ADMCLN
+5 IF '$GET(RXIEN)
QUIT 0
+6 IF 'FILL
SET ADMCLN=+$$GET1^DIQ(52,RXIEN,14,"I")
+7 IF FILL
SET ADMCLN=+$$GET1^DIQ(52.1,FILL_","_RXIEN,23,"I")
+8 QUIT ADMCLN
+9 ;
SPOK(STATE) ; State Parameters OK?
+1 ; Input: STATE - STATE file (#5) pointer
+2 NEW ZNODE,FNODE,F1NODE,X,STATENAM
+3 SET STATENAM=$$GET1^DIQ(5,+$GET(STATE),.01)
+4 IF '$DATA(^PS(58.41,+$GET(STATE),0))
QUIT "-1^PMP parameters missing for "_STATENAM
+5 SET ZNODE=$GET(^PS(58.41,STATE,0))
+6 IF $PIECE(ZNODE,"^",2)=""
QUIT "-1^ASAP Version missing for "_STATENAM
+7 IF $PIECE(ZNODE,"^",4)=""
QUIT "-1^Reporting Frequency missing for "_STATENAM
+8 SET FNODE=$GET(^PS(58.41,STATE,"FILE"))
+9 SET F1NODE=$GET(^PS(58.41,STATE,"FILE1"))
+10 IF $$OS^%ZOSV()["VMS"
IF $PIECE(FNODE,"^",1)=""
QUIT "-1^Local VMS Directory missing for "_STATENAM
+11 IF $$OS^%ZOSV()["UNIX"
IF $PIECE(F1NODE,"^",1)=""
QUIT "-1^Local Unix/Linux Directory missing for "_STATENAM
+12 IF $PIECE(FNODE,"^",4)=""
QUIT "-1^State FTP Server IP Address missing for "_STATENAM
+13 IF $PIECE(FNODE,"^",5)=""
QUIT "-1^State FTP Server username missing for "_STATENAM
+14 IF $PIECE(ZNODE,"^",6)="A"
IF '$ORDER(^PS(58.41,STATE,"PRVKEY",0))
QUIT "-1^SSH Keys missing for "_STATENAM
+15 QUIT 1
+16 ;
SETNAME(DFN) ; Set array variable PSONAME with Patient name
+1 NEW NCIEN
KILL PSONAME
+2 SET NCIEN=$$GET1^DIQ(2,DFN,1.01,"I")
+3 IF NCIEN
IF $$GET1^DIQ(20,NCIEN,1)'=""
IF $$GET1^DIQ(20,NCIEN,2)'=""
Begin DoDot:1
+4 SET PSONAME("LAST")=$$GET1^DIQ(20,NCIEN,1)
+5 SET PSONAME("FIRST")=$$GET1^DIQ(20,NCIEN,2)
+6 SET PSONAME("MIDDLE")=$$GET1^DIQ(20,NCIEN,3)
+7 SET PSONAME("PREFIX")=$$GET1^DIQ(20,NCIEN,4)
+8 SET PSONAME("SUFFIX")=$$GET1^DIQ(20,NCIEN,5)
End DoDot:1
QUIT
+9 ;
+10 SET PSONAME("LAST")=$PIECE($GET(VADM(1)),",",1)
+11 SET PSONAME("FIRST")=$PIECE($PIECE($GET(VADM(1)),",",2)," ",1)
+12 SET PSONAME("MIDDLE")=$PIECE($PIECE($GET(VADM(1)),",",2)," ",2)
+13 SET PSONAME("SUFFIX")=""
+14 SET PSONAME("PREFIX")=""
+15 QUIT
+16 ;
LOGERROR(BATCHIEN,STATEIEN,ERROR,BCKGRND,LOGFILE) ; Log/Display an error in the transmission
+1 ;Input: (r) BATCHIEN - Pointer to the SPMP EXPORT BATCH file (#58.42)
+2 ; (r) STATEIEN - Pointer ot the STATE file (#5)
+3 ; (r) ERROR - Error Text
+4 ; (r) BCKGRND - Background execution (1: Yes / 0: No)
+5 ; (o) LOGFILE - Filename of the file containing the sFTP Log (VMS only)
+6 IF '$GET(BCKGRND)
WRITE !!,ERROR,!,$CHAR(7)
QUIT
+7 ;
+8 ;Builds mail message and sends it to users of PSO SPMP NOTIFICATIONS mail group
+9 NEW XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ,PSOMSG,USR,STANAME,LINE
+10 ;
+11 SET STANAME=$SELECT($GET(BATCHIEN):$$GET1^DIQ(58.42,BATCHIEN,1),1:$$GET1^DIQ(5,STATEIEN,.01))
+12 SET XMSUB=STANAME_" Prescription Monitoring Program Transmission Failed"
+13 SET XMDUZ="SPMP TRANSMISSION"
+14 SET PSOMSG(1)="There was a problem with the transmission of information about Controlled"
+15 SET PSOMSG(2)="Substance prescriptions to the "_STANAME_" State Prescription Monitoring"
+16 SET PSOMSG(3)="Program (SPMP)."
+17 SET PSOMSG(4)=""
SET LINE=5
+18 IF $GET(BATCHIEN)
Begin DoDot:1
+19 SET PSOMSG(LINE)="Batch #: "_BATCHIEN
SET LINE=LINE+1
+20 IF $$GET1^DIQ(58.42,BATCHIEN,4,"I")
Begin DoDot:2
+21 SET PSOMSG(LINE)="Period : "_$$FMTE^XLFDT($$GET1^DIQ(58.42,BATCHIEN,4,"I")\1,"2Z")
+22 SET PSOMSG(LINE)=PSOMSG(LINE)_" thru "_$$FMTE^XLFDT($$GET1^DIQ(58.42,BATCHIEN,5,"I")\1,"2Z")
SET LINE=LINE+1
End DoDot:2
+23 SET PSOMSG(LINE)="Error : "_ERROR
SET LINE=LINE+1
+24 SET PSOMSG(LINE)=""
SET LINE=LINE+1
+25 SET PSOMSG(LINE)="Please, use the option Export Batch Processing [PSO SPMP BATCH PROCESSING] to"
SET LINE=LINE+1
+26 SET PSOMSG(LINE)="manually transmit this batch to the state."
SET LINE=LINE+1
End DoDot:1
+27 IF '$TEST
SET PSOMSG(LINE)="Error : "_ERROR
SET LINE=LINE+1
+28 SET XMTEXT="PSOMSG("
+29 ;
+30 ; Loading the VMS Log into the Mailman Message
+31 IF $GET(LOGFILE)'=""
Begin DoDot:1
+32 NEW LOCDIR,FILEARR,LOG,XLOG
+33 SET LOCDIR=$$GET1^DIQ(58.41,+$$GET1^DIQ(58.42,BATCHIEN,1,"I"),$SELECT($$OS^%ZOSV()["VMS":4,1:15))
IF LOCDIR=""
QUIT
+34 IF '$$FEXIST(LOCDIR,LOGFILE)
QUIT
+35 SET PSOMSG(LINE)=""
SET LINE=LINE+1
+36 SET PSOMSG(LINE)="sFTP Log:"
SET LINE=LINE+1
+37 SET PSOMSG(LINE)="========"
SET LINE=LINE+1
+38 KILL ^TMP("PSOFTPLG",$JOB)
+39 SET XLOG=$$FTG^%ZISH(LOCDIR,LOGFILE,$NAME(^TMP("PSOFTPLG",$JOB,1)),3)
+40 SET LOG=0
FOR
SET LOG=$ORDER(^TMP("PSOFTPLG",$JOB,LOG))
if LOG=""
QUIT
Begin DoDot:2
+41 SET PSOMSG(LINE)=$GET(^TMP("PSOFTPLG",$JOB,LOG))
SET LINE=LINE+1
End DoDot:2
End DoDot:1
+42 ;
+43 ; If there are no active members in the mailgroup sends message to PSDMGR key holders
+44 IF $$GOTLOCAL^XMXAPIG("PSO SPMP NOTIFICATIONS")
Begin DoDot:1
+45 SET XMY("G.PSO SPMP NOTIFICATIONS")=""
End DoDot:1
+46 IF '$TEST
Begin DoDot:1
+47 SET USR=0
FOR
SET USR=$ORDER(^XUSEC("PSDMGR",USR))
if 'USR
QUIT
SET XMY(USR)=""
End DoDot:1
+48 DO ^XMD
+49 QUIT
+50 ;
PREIEN(RECTYPE,RXIEN,FILLNUM) ; Returns the Provider IEN
+1 ;Input: RECTYPE - Record Type ('S': SEND, 'R': REVIEW, 'V': VOID)
+2 ; RXIEN - PRESCRIPTION file (#52) IEN
+3 ; FILLNUM - Fill Number
+4 QUIT +$SELECT(RECTYPE="V"&($GET(RTSDATA("PRVIEN"))):RTSDATA("PRVIEN"),1:$$RXPRV^PSOBPSUT(RXIEN,FILLNUM))
+5 ;
RPHIEN(RECTYPE,RXIEN,FILLNUM) ; Returns the Pharmacist IEN
+1 ;Input: RECTYPE - Record Type ('S': SEND, 'R': REVIEW, 'V': VOID)
+2 ; RXIEN - PRESCRIPTION file (#52) IEN
+3 ; FILLNUM - Fill Number
+4 QUIT +$SELECT(RECTYPE="V"&($GET(RTSDATA("RPHIEN"))):RTSDATA("RPHIEN"),1:$$RXRPH^PSOBPSUT(RXIEN,FILLNUM))
+5 ;
FEXIST(DIR,FILE) ; Check if a File exists
+1 ; Input: DIR - Name of the directory where the file is located
+2 ; FILE - Name of the file to be checked
+3 ;Output: $$FEXIST - 1 - File Exists / 0 - File Not Found
+4 NEW RETURN,FILEARR
+5 SET FILEARR(FILE)=""
+6 QUIT +$$LIST^%ZISH(DIR,"FILEARR","RETURN")
+7 ;
ESC(VALUE) ; Removes Control Characters from the Data Element Value
+1 NEW ESCVALUE,I
+2 SET ESCVALUE=""
+3 FOR I=1:1:$LENGTH(VALUE)
IF $ASCII(VALUE,I)>31
IF $ASCII(VALUE,I)<127
SET ESCVALUE=ESCVALUE_$EXTRACT(VALUE,I)
+4 QUIT ESCVALUE
+5 ;
