PSOSPMU1 ;BIRM/MFR - State Prescription Monitoring Program Utilities ;10/07/12
;;7.0;OUTPATIENT PHARMACY;**408,437,451,625,630,662,696,746**;DEC 1997;Build 106
;
GATHER(STATE,BEGDTTM,ENDDTTM,RECTYPE,RTSONLY,LIST) ; Gathers all CS prescriptions for Data Range
;Input: STATE - Pointer to the STATE file (#5)
; BEGDTTM - Date Range Begin Date/Time
; ENDDTTM - Date Range End Date/Time
; RECTYPE - Record Type for Released Rx's only (N: New / R: Revise)
; RTSONLY - Return To Stock Fills Only (1: YES / 0: NO)
; LIST - List of Filter(s) to be screened (LIST="PR" or "DR" or "PA" or "NC" or "RX", LIST(PROV IEN) or (LIST(PAT IEN) or LIST(RXIEN,FILL)
;Output: $$GATHER - Number of Rx's found
; ^TMP("PSOSPMRX",$J,STATE,RX,FILL)=Record Type (N/R/V) - List of Rx's gathered
; ^TMP("PSOSPMST",$J,$$RXSITE^PSOBPSUT(RXIEN,0))="" Zero Report - saving SITEs with RXs
N GATHER,XREF,RXRLDT,RXIEN,RXFILL,FILL,RTSDT,ENDRTSDT
S GATHER=0 K ^TMP("PSOSPMRX",$J),^TMP("PSOSPMST",$J) ;adding for Zero Report
I '$D(LIST) S LIST="NC" ; send all Rxs for a date range if no other criteria
; - Gathering Released Original Fills/Refills/Partials
I '$G(RTSONLY) D
. F XREF="AL","AM" D
. . S RXRLDT=BEGDTTM,ENDRLDT=ENDDTTM S:'$P(ENDRLDT,".",2) ENDRLDT=ENDRLDT+.25
. . F S RXRLDT=$O(^PSRX(XREF,RXRLDT)) Q:'RXRLDT!(RXRLDT>ENDRLDT) D
. . . S RXIEN=0 F S RXIEN=$O(^PSRX(XREF,RXRLDT,RXIEN)) Q:'RXIEN D
. . . . S RXFILL="" F S RXFILL=$O(^PSRX(XREF,RXRLDT,RXIEN,RXFILL)) Q:RXFILL="" D
. . . . . S FILL=$S(XREF="AL":RXFILL,1:"P"_RXFILL)
. . . . . I $$FILTER^PSOSPML7(.LIST,RXIEN,FILL) Q
. . . . . I $$SCREEN^PSOSPMUT(RXIEN,FILL) Q
. . . . . I $$RXSTATEZ^PSOBPSUT(RXIEN,0,STATE)=STATE S ^TMP("PSOSPMST",$J,$$RXSITE^PSOBPSUT(RXIEN,0))=""
. . . . . I $$RXSTATEP^PSOBPSUT(RXIEN,0,STATE)'[("^"_STATE_"^") Q ;P662
. . . . . S ^TMP("PSOSPMRX",$J,STATE,RXIEN,FILL)=RECTYPE
. . . . . S GATHER=GATHER+1
;
; ASAP 1995 does not support transmissions of Return To Stock fills in the same file
I $$GET1^DIQ(58.41,STATE,1,"I")="1995",'$G(RTSONLY) Q GATHER
;
I LIST'="NC" Q GATHER ; PSO*7*625/PSU-792 don't gather return to stock fills if user selects "PR", "DR", "PA", "DV", or "RX" criteria filters via MA option
;
; - Gathering Fills Returned To Stock
S RTSDT=BEGDTTM-.0000001,ENDRTSDT=ENDDTTM
S:'$P(ENDRTSDT,".",2) ENDRTSDT=ENDRTSDT+.25
F S RTSDT=$O(^PSRX("ARTS",RTSDT)) Q:'RTSDT!(RTSDT>ENDRTSDT) D
. S RXIEN=0 F S RXIEN=$O(^PSRX("ARTS",RTSDT,RXIEN)) Q:'RXIEN D
. . S RTSIEN=0 F S RTSIEN=$O(^PSRX("ARTS",RTSDT,RXIEN,RTSIEN)) Q:'RTSIEN D
. . . S FILL=$$GET1^DIQ(52.07,RTSIEN_","_RXIEN,1,"I")
. . . ; Rx Fill was never sent to SPMP so no need to VOID it
. . . I '$D(^PS(58.42,"ARX",RXIEN,FILL)) Q
. . . I $$RXRLDT^PSOBPSUT(RXIEN,FILL) Q
. . . I $$SCREEN^PSOSPMUT(RXIEN,FILL) Q
. . . I $D(^TMP("PSOSPMRX",$J,STATE,RXIEN,FILL)) Q
. . . I $$RXSTATEZ^PSOBPSUT(RXIEN,0,STATE)=STATE S ^TMP("PSOSPMST",$J,$$RXSITE^PSOBPSUT(RXIEN,0))=""
. . . N MBMST,STATECK ;P696 Start
. . . S MBMST=$$GET1^DIQ(58.41,STATE,21,"I")
. . . I (+MBMST=2) S STATECK=$$VOIDST^PSOSPMV(RXIEN,FILL) D Q
. . . . I STATE=STATECK S ^TMP("PSOSPMRX",$J,STATECK,RXIEN,FILL)="V" S GATHER=GATHER+1 ;P696 End
. . . I $$RXSTATEP^PSOBPSUT(RXIEN,0,STATE)'[("^"_STATE_"^") Q ;P662
. . . S ^TMP("PSOSPMRX",$J,STATE,RXIEN,FILL)="V"
. . . ;S ^TMP("PSOSPMST",$J,$$RXSITE^PSOBPSUT(RXIEN,0))="" ;PSO*7*625
. . . S GATHER=GATHER+1
Q GATHER
;
BLDBAT(EXPTYPE,BEGRLDT,ENDRLDT) ; Given a list of Rx's builds a new Export Batch
; Input: (r) EXPTYPE - Export Type ((MA)naul/(SC)heduled/(RX) Single Rx)/(VD) Void Only/(ZR) Zero Report
; (o) BEGRLDT - Begin Release Date (FM Format) (Required for M and S batches)
; (o) ENDRLDT - End Release Date (FM Format) (Required for M and S batches)
; (r) List of Rx's: ^TMP("PSOSPMRX",$J,STATE,RXIEN,RXFILL)=Record Type ((N)ew/(R)evise/(V)oid)
; Note: This ^TMP global will be cleaned up at the end
;Output: BATCHIEN - New Batch IEN (Pointer to #58.42) OR "01^Error Message"
N STATE,SPOK,RX,FILL,BATCHIEN,DRUGIEN,%,DIC,DR,DA,X,Y,XX,DINUM,DLAYGO,DD,DO,NDC,RECTYPE
I '$O(^TMP("PSOSPMRX",$J,0)) Q "-1^No prescription data"
;
S (STATE,RX)=0,FILL=""
F S STATE=$O(^TMP("PSOSPMRX",$J,STATE)) Q:'STATE D I $P(BATCHIEN,"^")=-1 Q
. S XX=$$SPOK^PSOSPMUT(STATE) I $P(XX,"^",1)=-1 S BATCHIEN=XX Q
. F L +^PS(58.42,0):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) Q:$T H 3
. S (DINUM,BATCHIEN)=$O(^PS(58.42,999999999999),-1)+1
. I EXPTYPE'="VD" W !!,"Creating Batch #",DINUM," for ",$$GET1^DIQ(58.41,STATE,.01),"..."
. S DIC="^PS(58.42,",X=DINUM,DIC(0)="",DIC("DR")="1////"_STATE_";2///"_EXPTYPE_";8///"_$$NOW^XLFDT()
. I $G(DUZ)>0 I $D(^XUSEC("PSO SPMP ADMIN",DUZ)) S DIC("DR")=DIC("DR")_";10////"_DUZ ; PSO*7*625 - PSU-14 VOID
. I $G(BEGRLDT) D
. . S DIC("DR")=DIC("DR")_";4///"_BEGRLDT_";5///"_$G(ENDRLDT)
. S DLAYGO=58.42 K DD,DO D FILE^DICN K DD,DO
. L -^PS(58.42,0)
. I Y=-1 S BATCHIEN="-1^Export Batch could not be created" Q
. F S RX=$O(^TMP("PSOSPMRX",$J,STATE,RX)) Q:'RX D
. . S DRUGIEN=$$GET1^DIQ(52,RX,6,"I")
. . F S FILL=$O(^TMP("PSOSPMRX",$J,STATE,RX,FILL)) Q:FILL="" D
. . . K DIC,DINUM,DA S DIC="^PS(58.42,"_BATCHIEN_",""RX"",",DIC(0)="",DA(1)=BATCHIEN
. . . S RECTYPE=^TMP("PSOSPMRX",$J,STATE,RX,FILL)
. . . I RECTYPE="V" D
. . . . S NDC=$$GETNDC(RX,FILL)
. . . E D
. . . . I $L($$NUMERIC^PSOASAP0($$GET1^DIQ(50,DRUGIEN,31)))=11 D
. . . . . S NDC=$$GET1^DIQ(50,DRUGIEN,31)
. . . . E S NDC=$$GETNDC^PSONDCUT(RX,+FILL)
. . . S X=RX,DIC("DR")="1///"_FILL_";2///"_RECTYPE_";3///"_NDC
. . . S DLAYGO=58.42001 K DD,DO D FILE^DICN K DD,DO
. I EXPTYPE'="VD" W "Done."
K ^TMP("PSOSPMRX",$J)
Q BATCHIEN
;
LOADRTS(RXIEN,FILL,ARRAY) ; Load ARRAY with Return To Stock Information
;Input: RXIEN - Pointer to PRESCRIPTION file (#52)
; FILL - Fill # - "0":Original / "1"..:Refill #1... / "P1"..:Partial 1...
;Output:ARRAY - Return Array (most recent Return To Stock data for the fill)
N RTSIEN,NODE0,NODE1,NDC
K ARRAY S RTSIEN=0
F S RTSIEN=$O(^PSRX(RXIEN,"RTS",RTSIEN)) Q:'RTSIEN D
. S NODE0=$G(^PSRX(RXIEN,"RTS",RTSIEN,0))
. I $P(NODE0,"^",2)'=FILL Q
. S NODE1=$G(^PSRX(RXIEN,"RTS",RTSIEN,1))
. S NDC=$$GETNDC(RXIEN,FILL) I NDC="" S NDC=$P(NODE0,"^",15)
. S ARRAY("DIVISION")=$P(NODE0,"^",13) ; Division
. S ARRAY("RELDTTM")=$P(NODE1,"^",2) ; Release Date/Time
. S ARRAY("NDC")=NDC ; NDC
. S ARRAY("QTY")=$P(NODE0,"^",4) ; Quantity
. S ARRAY("DAYSUP")=$P(NODE0,"^",5) ; Days Supply
. S ARRAY("RPHIEN")=$P(NODE0,"^",9) ; Pharmacist IEN
. S ARRAY("PRVIEN")=$P(NODE1,"^",1) ; Provider IEN
Q
;
GETNDC(RXIEN,FILL) ; Get the SENT NDC for the Return To Stock (VOID) record
;Input: RXIEN - Pointer to PRESCRIPTION file (#52)
; FILL - Fill # - "0":Original / "1"..:Refill #1... / "P1"..:Partial 1...
;Output: $$GETNDC - Return To Stock NDC
N GETRSNDC,BATCH,RXREC,RXREC0
I '$G(RXIEN)!$G(FILL)="" Q ""
S GETRSNDC=""
S BATCH="" F S BATCH=$O(^PS(58.42,"ARX",RXIEN,FILL,BATCH),-1) Q:'BATCH D I GETRSNDC'="" Q
. S RXREC="" F S RXREC=$O(^PS(58.42,"ARX",RXIEN,FILL,BATCH,RXREC),-1) Q:'RXREC D I GETRSNDC'="" Q
. . S RXREC0=$G(^PS(58.42,BATCH,"RX",RXREC,0)) I $P(RXREC0,"^",3)="V" Q
. . S GETRSNDC=$P(RXREC0,"^",4)
Q GETRSNDC
;
PREPFILE(STATE,DATETIME,RTSONLY,DEBUG) ; Prepare Files (FTP Script and Output Data files)
;Input: STATE - Pointer to STATE file (#5)
; DATETIME - Date/Time for the file names (format: YYYYMMDDHHMMSS)
; RTSONLY - Return To Stock Only Batch? (1: YES)
; DEBUG - Debug Mode? (1:YES / 0:NO)
N PSOOS,LOCDIR,PREFIX,FILEXT,RENAME,FTPIP,FTPUSR,FTPPORT,FTPDIR,FTPFILE,INPTFILE,EXPFILE,LOGFILE
; - Operating System
S PSOOS=$$OS^%ZOSV()
;
I +$$SPOK^PSOSPMUT(STATE)=-1 Q $$SPOK^PSOSPMUT(STATE)
;
; - Retrieving the Local Directory for the corresponding OS
I PSOOS["VMS" S LOCDIR=$$GET1^DIQ(58.41,STATE,4)
I PSOOS["UNIX" S LOCDIR=$$GET1^DIQ(58.41,STATE,15)
;
S PREFIX=$$GET1^DIQ(58.41,STATE,5)
S FILEXT=$$GET1^DIQ(58.41,STATE,6)
S RENAME=$$GET1^DIQ(58.41,STATE,17,"I")
S FTPIP=$$GET1^DIQ(58.41,STATE,7)
S FTPUSR=$$GET1^DIQ(58.41,STATE,8)
S FTPPORT=$$GET1^DIQ(58.41,STATE,9)
S FTPDIR=$$GET1^DIQ(58.41,STATE,10)
;
S INPTFILE="SPMP_FTP_"_DATETIME_".INP"
I PSOOS["VMS" S FTPFILE="SPMP_FTP_"_DATETIME_".COM"
S LOGFILE="SPMP_FTP_"_DATETIME_".LOG"
S EXPFILE=PREFIX_DATETIME_$S(RENAME:".UP",1:FILEXT)
I $G(RTSONLY) S EXPFILE="BACK_"_EXPFILE
;
D OPEN^%ZISH("INPTFILE",LOCDIR,INPTFILE,"W") I POP Q "-1^FTP Script file <"_LOCDIR_INPTFILE_"> could not be created."
D USE^%ZISUTL("INPTFILE")
W:FTPDIR'="" "cd "_FTPDIR,!
W "put "_$S(PSOOS["UNIX":LOCDIR,1:"")_EXPFILE,!
W:PSOOS["UNIX" "lcd "_LOCDIR,!
W:RENAME "rename "_EXPFILE_" "_$P(EXPFILE,".UP")_FILEXT,!
W:PSOOS["VMS" "lrm "_EXPFILE,!
; W:PSOOS["UNIX" "!rm -f "_LOCDIR_EXPFILE,!
W "exit",!
D CLOSE^%ZISH("INPTFILE")
I POP Q "-1^FTP Input file <"_INPTFILE_"> cannot be created."
;
; This sFTP command file is not needed for Linux/Unix
I PSOOS["VMS" D I POP Q "-1^FTP Script file <"_LOCDIR_FTPFILE_"> could not be created."
. D OPEN^%ZISH("FTPFILE",LOCDIR,FTPFILE,"W")
. D USE^%ZISUTL("FTPFILE")
. ; VMS Secure FTP
. I PSOOS["VMS" D
. . W "$ SET VERIFY=(PROCEDURE,IMAGE)",!
. . I LOCDIR'="" W "$ SET DEFAULT "_LOCDIR,!
. . W "$ sftp"_$S($G(DEBUG):" -""D3""",1:"")_$S(FTPPORT:" -oPort="_FTPPORT,1:"")_" -oIdentityFile="""_$$XVMSDIR(LOCDIR)_"VMSSSHID."" -""B"" "_INPTFILE_" -oUser="_FTPUSR_" "_FTPIP,!
. . W "$ exit",!
. D CLOSE^%ZISH("FTPFILE")
;
I PSOOS["VMS" D I POP Q "-1^FTP Script file <"_LOCDIR_"VMSSSHID.> could not be created."
. D OPEN^%ZISH("VMSSSHID",LOCDIR,"VMSSSHID.","W")
. D USE^%ZISUTL("VMSSSHID")
. W "IDKEY "_$$XVMSDIR(LOCDIR)_"VMSSSHKEY"
. D CLOSE^%ZISH("FTPFILE")
;
D SAVEKEYS(STATE,LOCDIR)
;
Q (LOCDIR_"^"_EXPFILE_"^"_$G(FTPFILE)_"^"_$G(INPTFILE)_"^"_$G(LOGFILE)_"^"_PREFIX_DATETIME_FILEXT)
;
FTPFILE(STATEIP,STATEUSR,LOCDIR,FTPFILE,EXPFILE,INPTFILE,LOGFILE,FTPPORT,DEBUG) ; Issue the Secure FTP command
;Input: STATEIP - State Server IP Address
; STATEUSR - Username at the State Server
; LOCDIR - Local Directory
; FTPFILE - sFTP executable batch file (VMS and NT only)
; EXPFILE - Data Export File
; INPTFILE - sFTP input file
; LOGFILE - sFTP Capture Log File (VMS only)
; FTPPORT - State Server Port #
; DEBUG - Debug Mode? (1:YES / 0:NO)
N PSOOS,PV,XPV1
S PSOOS=$$OS^%ZOSV()
I PSOOS["VMS" S XPV1="S PV=$ZF(-1,""@"_LOCDIR_FTPFILE_"/OUTPUT="_LOCDIR_LOGFILE_""")"
I PSOOS["UNIX" D
. S XPV1="S PV=$ZF(-1,""sftp"_$S($G(DEBUG):" -oLogLevel=DEBUG1",1:"")_$S(FTPPORT:" -oPort="_FTPPORT,1:"")_" -oIdentityFile="""""_LOCDIR_"linuxsshkey"""" -b "_LOCDIR_INPTFILE
. S XPV1=XPV1_" -oStrictHostKeyChecking=no -oUser="_$TR(STATEUSR,"""","")_" "_STATEIP_" >> "_LOCDIR_LOGFILE_""")"
;
X XPV1 ; Execute the FTP command
;
; Error flag logic
I PV=-1 Q "-1^Secure FTP Transmission failed"
;
; If Export File exists locally it means the sFTP did not finish because it removes the local file
N FILEARR,ERROR
;I PSOOS["VMS" S FILEARR(EXPFILE)="" I $$FEXIST^%ZISH(LOCDIR,"FILEARR") S ERROR=1
I PSOOS["VMS" I $$FEXIST^PSOSPMUT(LOCDIR,EXPFILE) S ERROR=1
I PSOOS["UNIX" D
. N XLOG,LOG,LINE
. S ERROR=1 K ^TMP("PSOFTPLG",$J)
. S XLOG=$$FTG^%ZISH(LOCDIR,LOGFILE,$NAME(^TMP("PSOFTPLG",$J,1)),3)
. S (LOG,LINE)=0
. F S LOG=$O(^TMP("PSOFTPLG",$J,LOG)) Q:LOG="" D I 'ERROR Q
. . S LINE=$G(^TMP("PSOFTPLG",$J,LOG)) I $$UP^XLFSTR(LINE)["SFTP> EXIT" S ERROR=0
;
I $G(ERROR) Q "-1^Secure FTP Transmission failed."
;
Q ""
;
DELFILES(LOCDIR,EXPFILE,INPTFILE,FTPFILE,LOGFILE) ; Delete Files
;Input: LOCDIR - Local Directory
; EXPFILE - Data Export File
; INPTFILE - sFTP input file
; FTPFILE - sFTP executable batch file (VMS and NT only)
; LOGFILE - sFTP Log Capture batch file (VMS and NT only)
N FILE2DEL,PSOOS ;,FILEARR
I $G(LOCDIR)="" Q
S PSOOS=$$OS^%ZOSV()
I $G(EXPFILE)'="",$$FEXIST^PSOSPMUT(LOCDIR,EXPFILE) S FILE2DEL(EXPFILE)=""
S:$G(INPTFILE)'="" FILE2DEL(INPTFILE)=""
S:$G(LOGFILE)'="" FILE2DEL(LOGFILE)=""
I PSOOS["VMS" D
. S:$G(FTPFILE)'="" FILE2DEL(FTPFILE)=""
. S FILE2DEL("VMSSSHID.")=""
. S FILE2DEL("VMSSSHKEY.")=""
. S FILE2DEL("VMSSSHKEY.PUB")=""
I PSOOS["UNIX" D
. S FILE2DEL("VMSSSHKEY")=""
. S FILE2DEL("linuxsshkey")=""
D DEL^%ZISH(LOCDIR,"FILE2DEL")
Q
;
PAUSE ; Pauses screen until user hits Return
N DIR
W ! S DIR("A")="Press Return to continue",DIR(0)="E" D ^DIR
Q
;
XVMSDIR(VMSDIR) ; Converts a VMS directory
; Input: VMSDIR - OpenVMS directory name (e.g., "USER$:[SPMP]")
;Output: $$XVMSDIR - Converted VMS directory (e.g., "/USER$/SPMP/")
Q "/"_$TR(VMSDIR,".[]:","///")
;
SAVEKEYS(STATE,LOCDIR) ; Saves Key, converts SSH2 to OpenSSH when running on Linux
;Input: STATE - State to retrieve the keys from
; LOCDIR - Local directory where the keys should be saved to
N WLINE,XPV
I $$GET1^DIQ(58.41,STATE,18,"I")="SSH2" D
. ;Saving the Private SSH Key
. D OPEN^%ZISH("VMSSSHKEY",LOCDIR,"VMSSSHKEY","W")
. D USE^%ZISUTL("VMSSSHKEY")
. F WLINE=1:1 Q:'$D(^PS(58.41,STATE,"PRVKEY",WLINE)) D
. . W $$DECRYP^XUSRB1(^PS(58.41,STATE,"PRVKEY",WLINE,0)),!
. D CLOSE^%ZISH("VMSSSHKEY")
;
I $$OS^%ZOSV()["VMS" D Q
. ;Saving the Public SSH Key (Assuming SSH2 format) - VMS Only
. D OPEN^%ZISH("VMSSSHKEY",LOCDIR,"VMSSSHKEY.PUB","W")
. D USE^%ZISUTL("VMSSSHKEY")
. F WLINE=1:1 Q:'$D(^PS(58.41,STATE,"PUBKEY",WLINE)) D
. . W $$DECRYP^XUSRB1(^PS(58.41,STATE,"PUBKEY",WLINE,0)),!
. D CLOSE^%ZISH("VMSSSHKEY")
;
I $$OS^%ZOSV()["UNIX" D Q
. ;If Key format is SSH2, convert VMSSSHKEY to OpenSSH format; Otherwise write directly from VistA
. I $$GET1^DIQ(58.41,STATE,18,"I")="SSH2" D
. . S XPV="S PV=$ZF(-1,""ssh-keygen -i -f "_LOCDIR_"VMSSSHKEY > "_LOCDIR_"linuxsshkey"")"
. . X XPV
. E D
. . ;Saving the Private SSH Key (OpenSSH Format)
. . D OPEN^%ZISH("linuxsshkey",LOCDIR,"linuxsshkey","W")
. . D USE^%ZISUTL("linuxsshkey")
. . F WLINE=1:1 Q:'$D(^PS(58.41,STATE,"PRVKEY",WLINE)) D
. . . W $$DECRYP^XUSRB1(^PS(58.41,STATE,"PRVKEY",WLINE,0)),!
. . D CLOSE^%ZISH("linuxsshkey")
. S XPV="S PV=$ZF(-1,""chmod 600 "_LOCDIR_"linuxsshkey"")"
. X XPV
;
Q
;
LINUXDIR() ; Returns the Linux Directory for SPMP sFTP
N CURDIR,ROOTDIR,PSOVER
I $$OS^%ZOSV()'="UNIX" Q ""
S PSOVER=$$UP^XLFSTR($$VERSION^%ZOSV(1))
I PSOVER'["CACHE",PSOVER'["IRIS" Q "" ;PSO*7*630
; Retrieving the current directory
X "S CURDIR=$ZU(12)" S ROOTDIR=$P(CURDIR,"/",1,4)
I $E(ROOTDIR,$L(ROOTDIR))="/" S $E(ROOTDIR,$L(ROOTDIR))=""
Q ROOTDIR_"/user/sftp/spmp/"
;
DIREXIST(DIR) ; Returns whether the Linux Directory for SPMP sFTP already exists
;Input: DIR - Linux Directory name to be checked
N DIREXIST,PSOVER
I DIR="" Q 0
I $$OS^%ZOSV()'="UNIX" Q 0
S PSOVER=$$UP^XLFSTR($$VERSION^%ZOSV(1))
I PSOVER'["CACHE",PSOVER'["IRIS" Q 0 ;PSO*7*630
I $E(DIR,$L(DIR))="/" S $E(DIR,$L(DIR))=""
X "S DIREXIST=$ZSEARCH(DIR)"
Q $S(DIREXIST="":0,1:1)
;
MAKEDIR(DIR) ; Create a new directory
;Input: DIR - Linux Directory name to be created
N MKDIR,PSOVER
I $$OS^%ZOSV()'="UNIX" Q
S PSOVER=$$UP^XLFSTR($$VERSION^%ZOSV(1))
I PSOVER'["CACHE",PSOVER'["IRIS" Q ;PSO*7*630
I $$DIREXIST(DIR) Q
X "S MKDIR=$ZF(-1,""mkdir ""_DIR)"
I 'MKDIR X "S MKDIR=$ZF(-1,""chmod 777 ""_DIR)"
Q
;
SETLN(NSPC,TEXT,REV,UND,HIG) ; Sets a line to be displayed in the Body section
;Input: NSPC - Namespace of the ^TMP global
; TEXT - Line of text to be added to Listman
; REV - Reverse video (1: YES / 0:NO)
; UND - Underlined (1: YES / 0: NO)
; HIG - Highlighted (1: YES / 0: NO)
N X
S:$G(TEXT)="" $E(TEXT,80)=""
S:$L(TEXT)>80 TEXT=$E(TEXT,1,80)
S LINE=LINE+1,^TMP(NSPC,$J,LINE,0)=$G(TEXT)
;
I LINE>$G(PSOLSTLN) D SAVE^VALM10(LINE) S PSOLSTLN=LINE
;
I $G(REV) D Q
. D CNTRL^VALM10(LINE,1,$L(TEXT),IORVON,IORVOFF_IOINORM)
. I $G(UND) D CNTRL^VALM10(LINE,$L(TEXT)+1,80,IOUON,IOINORM)
I $G(UND) D CNTRL^VALM10(LINE,1,80,IOUON,IOINORM)
I $G(HIG) D
. D CNTRL^VALM10(LINE,HIG,80,IOINHI_$S($G(UND):IOUON,1:""),IOINORM)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOSPMU1 16558 printed Oct 16, 2024@18:35:50 Page 2
PSOSPMU1 ;BIRM/MFR - State Prescription Monitoring Program Utilities ;10/07/12
+1 ;;7.0;OUTPATIENT PHARMACY;**408,437,451,625,630,662,696,746**;DEC 1997;Build 106
+2 ;
GATHER(STATE,BEGDTTM,ENDDTTM,RECTYPE,RTSONLY,LIST) ; Gathers all CS prescriptions for Data Range
+1 ;Input: STATE - Pointer to the STATE file (#5)
+2 ; BEGDTTM - Date Range Begin Date/Time
+3 ; ENDDTTM - Date Range End Date/Time
+4 ; RECTYPE - Record Type for Released Rx's only (N: New / R: Revise)
+5 ; RTSONLY - Return To Stock Fills Only (1: YES / 0: NO)
+6 ; LIST - List of Filter(s) to be screened (LIST="PR" or "DR" or "PA" or "NC" or "RX", LIST(PROV IEN) or (LIST(PAT IEN) or LIST(RXIEN,FILL)
+7 ;Output: $$GATHER - Number of Rx's found
+8 ; ^TMP("PSOSPMRX",$J,STATE,RX,FILL)=Record Type (N/R/V) - List of Rx's gathered
+9 ; ^TMP("PSOSPMST",$J,$$RXSITE^PSOBPSUT(RXIEN,0))="" Zero Report - saving SITEs with RXs
+10 NEW GATHER,XREF,RXRLDT,RXIEN,RXFILL,FILL,RTSDT,ENDRTSDT
+11 ;adding for Zero Report
SET GATHER=0
KILL ^TMP("PSOSPMRX",$JOB),^TMP("PSOSPMST",$JOB)
+12 ; send all Rxs for a date range if no other criteria
IF '$DATA(LIST)
SET LIST="NC"
+13 ; - Gathering Released Original Fills/Refills/Partials
+14 IF '$GET(RTSONLY)
Begin DoDot:1
+15 FOR XREF="AL","AM"
Begin DoDot:2
+16 SET RXRLDT=BEGDTTM
SET ENDRLDT=ENDDTTM
if '$PIECE(ENDRLDT,".",2)
SET ENDRLDT=ENDRLDT+.25
+17 FOR
SET RXRLDT=$ORDER(^PSRX(XREF,RXRLDT))
if 'RXRLDT!(RXRLDT>ENDRLDT)
QUIT
Begin DoDot:3
+18 SET RXIEN=0
FOR
SET RXIEN=$ORDER(^PSRX(XREF,RXRLDT,RXIEN))
if 'RXIEN
QUIT
Begin DoDot:4
+19 SET RXFILL=""
FOR
SET RXFILL=$ORDER(^PSRX(XREF,RXRLDT,RXIEN,RXFILL))
if RXFILL=""
QUIT
Begin DoDot:5
+20 SET FILL=$SELECT(XREF="AL":RXFILL,1:"P"_RXFILL)
+21 IF $$FILTER^PSOSPML7(.LIST,RXIEN,FILL)
QUIT
+22 IF $$SCREEN^PSOSPMUT(RXIEN,FILL)
QUIT
+23 IF $$RXSTATEZ^PSOBPSUT(RXIEN,0,STATE)=STATE
SET ^TMP("PSOSPMST",$JOB,$$RXSITE^PSOBPSUT(RXIEN,0))=""
+24 ;P662
IF $$RXSTATEP^PSOBPSUT(RXIEN,0,STATE)'[("^"_STATE_"^")
QUIT
+25 SET ^TMP("PSOSPMRX",$JOB,STATE,RXIEN,FILL)=RECTYPE
+26 SET GATHER=GATHER+1
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+27 ;
+28 ; ASAP 1995 does not support transmissions of Return To Stock fills in the same file
+29 IF $$GET1^DIQ(58.41,STATE,1,"I")="1995"
IF '$GET(RTSONLY)
QUIT GATHER
+30 ;
+31 ; PSO*7*625/PSU-792 don't gather return to stock fills if user selects "PR", "DR", "PA", "DV", or "RX" criteria filters via MA option
IF LIST'="NC"
QUIT GATHER
+32 ;
+33 ; - Gathering Fills Returned To Stock
+34 SET RTSDT=BEGDTTM-.0000001
SET ENDRTSDT=ENDDTTM
+35 if '$PIECE(ENDRTSDT,".",2)
SET ENDRTSDT=ENDRTSDT+.25
+36 FOR
SET RTSDT=$ORDER(^PSRX("ARTS",RTSDT))
if 'RTSDT!(RTSDT>ENDRTSDT)
QUIT
Begin DoDot:1
+37 SET RXIEN=0
FOR
SET RXIEN=$ORDER(^PSRX("ARTS",RTSDT,RXIEN))
if 'RXIEN
QUIT
Begin DoDot:2
+38 SET RTSIEN=0
FOR
SET RTSIEN=$ORDER(^PSRX("ARTS",RTSDT,RXIEN,RTSIEN))
if 'RTSIEN
QUIT
Begin DoDot:3
+39 SET FILL=$$GET1^DIQ(52.07,RTSIEN_","_RXIEN,1,"I")
+40 ; Rx Fill was never sent to SPMP so no need to VOID it
+41 IF '$DATA(^PS(58.42,"ARX",RXIEN,FILL))
QUIT
+42 IF $$RXRLDT^PSOBPSUT(RXIEN,FILL)
QUIT
+43 IF $$SCREEN^PSOSPMUT(RXIEN,FILL)
QUIT
+44 IF $DATA(^TMP("PSOSPMRX",$JOB,STATE,RXIEN,FILL))
QUIT
+45 IF $$RXSTATEZ^PSOBPSUT(RXIEN,0,STATE)=STATE
SET ^TMP("PSOSPMST",$JOB,$$RXSITE^PSOBPSUT(RXIEN,0))=""
+46 ;P696 Start
NEW MBMST,STATECK
+47 SET MBMST=$$GET1^DIQ(58.41,STATE,21,"I")
+48 IF (+MBMST=2)
SET STATECK=$$VOIDST^PSOSPMV(RXIEN,FILL)
Begin DoDot:4
+49 ;P696 End
IF STATE=STATECK
SET ^TMP("PSOSPMRX",$JOB,STATECK,RXIEN,FILL)="V"
SET GATHER=GATHER+1
End DoDot:4
QUIT
+50 ;P662
IF $$RXSTATEP^PSOBPSUT(RXIEN,0,STATE)'[("^"_STATE_"^")
QUIT
+51 SET ^TMP("PSOSPMRX",$JOB,STATE,RXIEN,FILL)="V"
+52 ;S ^TMP("PSOSPMST",$J,$$RXSITE^PSOBPSUT(RXIEN,0))="" ;PSO*7*625
+53 SET GATHER=GATHER+1
End DoDot:3
End DoDot:2
End DoDot:1
+54 QUIT GATHER
+55 ;
BLDBAT(EXPTYPE,BEGRLDT,ENDRLDT) ; Given a list of Rx's builds a new Export Batch
+1 ; Input: (r) EXPTYPE - Export Type ((MA)naul/(SC)heduled/(RX) Single Rx)/(VD) Void Only/(ZR) Zero Report
+2 ; (o) BEGRLDT - Begin Release Date (FM Format) (Required for M and S batches)
+3 ; (o) ENDRLDT - End Release Date (FM Format) (Required for M and S batches)
+4 ; (r) List of Rx's: ^TMP("PSOSPMRX",$J,STATE,RXIEN,RXFILL)=Record Type ((N)ew/(R)evise/(V)oid)
+5 ; Note: This ^TMP global will be cleaned up at the end
+6 ;Output: BATCHIEN - New Batch IEN (Pointer to #58.42) OR "01^Error Message"
+7 NEW STATE,SPOK,RX,FILL,BATCHIEN,DRUGIEN,%,DIC,DR,DA,X,Y,XX,DINUM,DLAYGO,DD,DO,NDC,RECTYPE
+8 IF '$ORDER(^TMP("PSOSPMRX",$JOB,0))
QUIT "-1^No prescription data"
+9 ;
+10 SET (STATE,RX)=0
SET FILL=""
+11 FOR
SET STATE=$ORDER(^TMP("PSOSPMRX",$JOB,STATE))
if 'STATE
QUIT
Begin DoDot:1
+12 SET XX=$$SPOK^PSOSPMUT(STATE)
IF $PIECE(XX,"^",1)=-1
SET BATCHIEN=XX
QUIT
+13 FOR
LOCK +^PS(58.42,0):$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
if $TEST
QUIT
HANG 3
+14 SET (DINUM,BATCHIEN)=$ORDER(^PS(58.42,999999999999),-1)+1
+15 IF EXPTYPE'="VD"
WRITE !!,"Creating Batch #",DINUM," for ",$$GET1^DIQ(58.41,STATE,.01),"..."
+16 SET DIC="^PS(58.42,"
SET X=DINUM
SET DIC(0)=""
SET DIC("DR")="1////"_STATE_";2///"_EXPTYPE_";8///"_$$NOW^XLFDT()
+17 ; PSO*7*625 - PSU-14 VOID
IF $GET(DUZ)>0
IF $DATA(^XUSEC("PSO SPMP ADMIN",DUZ))
SET DIC("DR")=DIC("DR")_";10////"_DUZ
+18 IF $GET(BEGRLDT)
Begin DoDot:2
+19 SET DIC("DR")=DIC("DR")_";4///"_BEGRLDT_";5///"_$GET(ENDRLDT)
End DoDot:2
+20 SET DLAYGO=58.42
KILL DD,DO
DO FILE^DICN
KILL DD,DO
+21 LOCK -^PS(58.42,0)
+22 IF Y=-1
SET BATCHIEN="-1^Export Batch could not be created"
QUIT
+23 FOR
SET RX=$ORDER(^TMP("PSOSPMRX",$JOB,STATE,RX))
if 'RX
QUIT
Begin DoDot:2
+24 SET DRUGIEN=$$GET1^DIQ(52,RX,6,"I")
+25 FOR
SET FILL=$ORDER(^TMP("PSOSPMRX",$JOB,STATE,RX,FILL))
if FILL=""
QUIT
Begin DoDot:3
+26 KILL DIC,DINUM,DA
SET DIC="^PS(58.42,"_BATCHIEN_",""RX"","
SET DIC(0)=""
SET DA(1)=BATCHIEN
+27 SET RECTYPE=^TMP("PSOSPMRX",$JOB,STATE,RX,FILL)
+28 IF RECTYPE="V"
Begin DoDot:4
+29 SET NDC=$$GETNDC(RX,FILL)
End DoDot:4
+30 IF '$TEST
Begin DoDot:4
+31 IF $LENGTH($$NUMERIC^PSOASAP0($$GET1^DIQ(50,DRUGIEN,31)))=11
Begin DoDot:5
+32 SET NDC=$$GET1^DIQ(50,DRUGIEN,31)
End DoDot:5
+33 IF '$TEST
SET NDC=$$GETNDC^PSONDCUT(RX,+FILL)
End DoDot:4
+34 SET X=RX
SET DIC("DR")="1///"_FILL_";2///"_RECTYPE_";3///"_NDC
+35 SET DLAYGO=58.42001
KILL DD,DO
DO FILE^DICN
KILL DD,DO
End DoDot:3
End DoDot:2
+36 IF EXPTYPE'="VD"
WRITE "Done."
End DoDot:1
IF $PIECE(BATCHIEN,"^")=-1
QUIT
+37 KILL ^TMP("PSOSPMRX",$JOB)
+38 QUIT BATCHIEN
+39 ;
LOADRTS(RXIEN,FILL,ARRAY) ; Load ARRAY with Return To Stock Information
+1 ;Input: RXIEN - Pointer to PRESCRIPTION file (#52)
+2 ; FILL - Fill # - "0":Original / "1"..:Refill #1... / "P1"..:Partial 1...
+3 ;Output:ARRAY - Return Array (most recent Return To Stock data for the fill)
+4 NEW RTSIEN,NODE0,NODE1,NDC
+5 KILL ARRAY
SET RTSIEN=0
+6 FOR
SET RTSIEN=$ORDER(^PSRX(RXIEN,"RTS",RTSIEN))
if 'RTSIEN
QUIT
Begin DoDot:1
+7 SET NODE0=$GET(^PSRX(RXIEN,"RTS",RTSIEN,0))
+8 IF $PIECE(NODE0,"^",2)'=FILL
QUIT
+9 SET NODE1=$GET(^PSRX(RXIEN,"RTS",RTSIEN,1))
+10 SET NDC=$$GETNDC(RXIEN,FILL)
IF NDC=""
SET NDC=$PIECE(NODE0,"^",15)
+11 ; Division
SET ARRAY("DIVISION")=$PIECE(NODE0,"^",13)
+12 ; Release Date/Time
SET ARRAY("RELDTTM")=$PIECE(NODE1,"^",2)
+13 ; NDC
SET ARRAY("NDC")=NDC
+14 ; Quantity
SET ARRAY("QTY")=$PIECE(NODE0,"^",4)
+15 ; Days Supply
SET ARRAY("DAYSUP")=$PIECE(NODE0,"^",5)
+16 ; Pharmacist IEN
SET ARRAY("RPHIEN")=$PIECE(NODE0,"^",9)
+17 ; Provider IEN
SET ARRAY("PRVIEN")=$PIECE(NODE1,"^",1)
End DoDot:1
+18 QUIT
+19 ;
GETNDC(RXIEN,FILL) ; Get the SENT NDC for the Return To Stock (VOID) record
+1 ;Input: RXIEN - Pointer to PRESCRIPTION file (#52)
+2 ; FILL - Fill # - "0":Original / "1"..:Refill #1... / "P1"..:Partial 1...
+3 ;Output: $$GETNDC - Return To Stock NDC
+4 NEW GETRSNDC,BATCH,RXREC,RXREC0
+5 IF '$GET(RXIEN)!$GET(FILL)=""
QUIT ""
+6 SET GETRSNDC=""
+7 SET BATCH=""
FOR
SET BATCH=$ORDER(^PS(58.42,"ARX",RXIEN,FILL,BATCH),-1)
if 'BATCH
QUIT
Begin DoDot:1
+8 SET RXREC=""
FOR
SET RXREC=$ORDER(^PS(58.42,"ARX",RXIEN,FILL,BATCH,RXREC),-1)
if 'RXREC
QUIT
Begin DoDot:2
+9 SET RXREC0=$GET(^PS(58.42,BATCH,"RX",RXREC,0))
IF $PIECE(RXREC0,"^",3)="V"
QUIT
+10 SET GETRSNDC=$PIECE(RXREC0,"^",4)
End DoDot:2
IF GETRSNDC'=""
QUIT
End DoDot:1
IF GETRSNDC'=""
QUIT
+11 QUIT GETRSNDC
+12 ;
PREPFILE(STATE,DATETIME,RTSONLY,DEBUG) ; Prepare Files (FTP Script and Output Data files)
+1 ;Input: STATE - Pointer to STATE file (#5)
+2 ; DATETIME - Date/Time for the file names (format: YYYYMMDDHHMMSS)
+3 ; RTSONLY - Return To Stock Only Batch? (1: YES)
+4 ; DEBUG - Debug Mode? (1:YES / 0:NO)
+5 NEW PSOOS,LOCDIR,PREFIX,FILEXT,RENAME,FTPIP,FTPUSR,FTPPORT,FTPDIR,FTPFILE,INPTFILE,EXPFILE,LOGFILE
+6 ; - Operating System
+7 SET PSOOS=$$OS^%ZOSV()
+8 ;
+9 IF +$$SPOK^PSOSPMUT(STATE)=-1
QUIT $$SPOK^PSOSPMUT(STATE)
+10 ;
+11 ; - Retrieving the Local Directory for the corresponding OS
+12 IF PSOOS["VMS"
SET LOCDIR=$$GET1^DIQ(58.41,STATE,4)
+13 IF PSOOS["UNIX"
SET LOCDIR=$$GET1^DIQ(58.41,STATE,15)
+14 ;
+15 SET PREFIX=$$GET1^DIQ(58.41,STATE,5)
+16 SET FILEXT=$$GET1^DIQ(58.41,STATE,6)
+17 SET RENAME=$$GET1^DIQ(58.41,STATE,17,"I")
+18 SET FTPIP=$$GET1^DIQ(58.41,STATE,7)
+19 SET FTPUSR=$$GET1^DIQ(58.41,STATE,8)
+20 SET FTPPORT=$$GET1^DIQ(58.41,STATE,9)
+21 SET FTPDIR=$$GET1^DIQ(58.41,STATE,10)
+22 ;
+23 SET INPTFILE="SPMP_FTP_"_DATETIME_".INP"
+24 IF PSOOS["VMS"
SET FTPFILE="SPMP_FTP_"_DATETIME_".COM"
+25 SET LOGFILE="SPMP_FTP_"_DATETIME_".LOG"
+26 SET EXPFILE=PREFIX_DATETIME_$SELECT(RENAME:".UP",1:FILEXT)
+27 IF $GET(RTSONLY)
SET EXPFILE="BACK_"_EXPFILE
+28 ;
+29 DO OPEN^%ZISH("INPTFILE",LOCDIR,INPTFILE,"W")
IF POP
QUIT "-1^FTP Script file <"_LOCDIR_INPTFILE_"> could not be created."
+30 DO USE^%ZISUTL("INPTFILE")
+31 if FTPDIR'=""
WRITE "cd "_FTPDIR,!
+32 WRITE "put "_$SELECT(PSOOS["UNIX":LOCDIR,1:"")_EXPFILE,!
+33 if PSOOS["UNIX"
WRITE "lcd "_LOCDIR,!
+34 if RENAME
WRITE "rename "_EXPFILE_" "_$PIECE(EXPFILE,".UP")_FILEXT,!
+35 if PSOOS["VMS"
WRITE "lrm "_EXPFILE,!
+36 ; W:PSOOS["UNIX" "!rm -f "_LOCDIR_EXPFILE,!
+37 WRITE "exit",!
+38 DO CLOSE^%ZISH("INPTFILE")
+39 IF POP
QUIT "-1^FTP Input file <"_INPTFILE_"> cannot be created."
+40 ;
+41 ; This sFTP command file is not needed for Linux/Unix
+42 IF PSOOS["VMS"
Begin DoDot:1
+43 DO OPEN^%ZISH("FTPFILE",LOCDIR,FTPFILE,"W")
+44 DO USE^%ZISUTL("FTPFILE")
+45 ; VMS Secure FTP
+46 IF PSOOS["VMS"
Begin DoDot:2
+47 WRITE "$ SET VERIFY=(PROCEDURE,IMAGE)",!
+48 IF LOCDIR'=""
WRITE "$ SET DEFAULT "_LOCDIR,!
+49 WRITE "$ sftp"_$SELECT($GET(DEBUG):" -""D3""",1:"")_$SELECT(FTPPORT:" -oPort="_FTPPORT,1:"")_" -oIdentityFile="""_$$XVMSDIR(LOCDIR)_"VMSSSHID."" -""B"" "_INPTFILE_" -oUser="_FTPUSR_" "_FTPIP,!
+50 WRITE "$ exit",!
End DoDot:2
+51 DO CLOSE^%ZISH("FTPFILE")
End DoDot:1
IF POP
QUIT "-1^FTP Script file <"_LOCDIR_FTPFILE_"> could not be created."
+52 ;
+53 IF PSOOS["VMS"
Begin DoDot:1
+54 DO OPEN^%ZISH("VMSSSHID",LOCDIR,"VMSSSHID.","W")
+55 DO USE^%ZISUTL("VMSSSHID")
+56 WRITE "IDKEY "_$$XVMSDIR(LOCDIR)_"VMSSSHKEY"
+57 DO CLOSE^%ZISH("FTPFILE")
End DoDot:1
IF POP
QUIT "-1^FTP Script file <"_LOCDIR_"VMSSSHID.> could not be created."
+58 ;
+59 DO SAVEKEYS(STATE,LOCDIR)
+60 ;
+61 QUIT (LOCDIR_"^"_EXPFILE_"^"_$GET(FTPFILE)_"^"_$GET(INPTFILE)_"^"_$GET(LOGFILE)_"^"_PREFIX_DATETIME_FILEXT)
+62 ;
FTPFILE(STATEIP,STATEUSR,LOCDIR,FTPFILE,EXPFILE,INPTFILE,LOGFILE,FTPPORT,DEBUG) ; Issue the Secure FTP command
+1 ;Input: STATEIP - State Server IP Address
+2 ; STATEUSR - Username at the State Server
+3 ; LOCDIR - Local Directory
+4 ; FTPFILE - sFTP executable batch file (VMS and NT only)
+5 ; EXPFILE - Data Export File
+6 ; INPTFILE - sFTP input file
+7 ; LOGFILE - sFTP Capture Log File (VMS only)
+8 ; FTPPORT - State Server Port #
+9 ; DEBUG - Debug Mode? (1:YES / 0:NO)
+10 NEW PSOOS,PV,XPV1
+11 SET PSOOS=$$OS^%ZOSV()
+12 IF PSOOS["VMS"
SET XPV1="S PV=$ZF(-1,""@"_LOCDIR_FTPFILE_"/OUTPUT="_LOCDIR_LOGFILE_""")"
+13 IF PSOOS["UNIX"
Begin DoDot:1
+14 SET XPV1="S PV=$ZF(-1,""sftp"_$SELECT($GET(DEBUG):" -oLogLevel=DEBUG1",1:"")_$SELECT(FTPPORT:" -oPort="_FTPPORT,1:"")_" -oIdentityFile="""""_LOCDIR_"linuxsshkey"""" -b "_LOCDIR_INPTFILE
+15 SET XPV1=XPV1_" -oStrictHostKeyChecking=no -oUser="_$TRANSLATE(STATEUSR,"""","")_" "_STATEIP_" >> "_LOCDIR_LOGFILE_""")"
End DoDot:1
+16 ;
+17 ; Execute the FTP command
XECUTE XPV1
+18 ;
+19 ; Error flag logic
+20 IF PV=-1
QUIT "-1^Secure FTP Transmission failed"
+21 ;
+22 ; If Export File exists locally it means the sFTP did not finish because it removes the local file
+23 NEW FILEARR,ERROR
+24 ;I PSOOS["VMS" S FILEARR(EXPFILE)="" I $$FEXIST^%ZISH(LOCDIR,"FILEARR") S ERROR=1
+25 IF PSOOS["VMS"
IF $$FEXIST^PSOSPMUT(LOCDIR,EXPFILE)
SET ERROR=1
+26 IF PSOOS["UNIX"
Begin DoDot:1
+27 NEW XLOG,LOG,LINE
+28 SET ERROR=1
KILL ^TMP("PSOFTPLG",$JOB)
+29 SET XLOG=$$FTG^%ZISH(LOCDIR,LOGFILE,$NAME(^TMP("PSOFTPLG",$JOB,1)),3)
+30 SET (LOG,LINE)=0
+31 FOR
SET LOG=$ORDER(^TMP("PSOFTPLG",$JOB,LOG))
if LOG=""
QUIT
Begin DoDot:2
+32 SET LINE=$GET(^TMP("PSOFTPLG",$JOB,LOG))
IF $$UP^XLFSTR(LINE)["SFTP> EXIT"
SET ERROR=0
End DoDot:2
IF 'ERROR
QUIT
End DoDot:1
+33 ;
+34 IF $GET(ERROR)
QUIT "-1^Secure FTP Transmission failed."
+35 ;
+36 QUIT ""
+37 ;
DELFILES(LOCDIR,EXPFILE,INPTFILE,FTPFILE,LOGFILE) ; Delete Files
+1 ;Input: LOCDIR - Local Directory
+2 ; EXPFILE - Data Export File
+3 ; INPTFILE - sFTP input file
+4 ; FTPFILE - sFTP executable batch file (VMS and NT only)
+5 ; LOGFILE - sFTP Log Capture batch file (VMS and NT only)
+6 ;,FILEARR
NEW FILE2DEL,PSOOS
+7 IF $GET(LOCDIR)=""
QUIT
+8 SET PSOOS=$$OS^%ZOSV()
+9 IF $GET(EXPFILE)'=""
IF $$FEXIST^PSOSPMUT(LOCDIR,EXPFILE)
SET FILE2DEL(EXPFILE)=""
+10 if $GET(INPTFILE)'=""
SET FILE2DEL(INPTFILE)=""
+11 if $GET(LOGFILE)'=""
SET FILE2DEL(LOGFILE)=""
+12 IF PSOOS["VMS"
Begin DoDot:1
+13 if $GET(FTPFILE)'=""
SET FILE2DEL(FTPFILE)=""
+14 SET FILE2DEL("VMSSSHID.")=""
+15 SET FILE2DEL("VMSSSHKEY.")=""
+16 SET FILE2DEL("VMSSSHKEY.PUB")=""
End DoDot:1
+17 IF PSOOS["UNIX"
Begin DoDot:1
+18 SET FILE2DEL("VMSSSHKEY")=""
+19 SET FILE2DEL("linuxsshkey")=""
End DoDot:1
+20 DO DEL^%ZISH(LOCDIR,"FILE2DEL")
+21 QUIT
+22 ;
PAUSE ; Pauses screen until user hits Return
+1 NEW DIR
+2 WRITE !
SET DIR("A")="Press Return to continue"
SET DIR(0)="E"
DO ^DIR
+3 QUIT
+4 ;
XVMSDIR(VMSDIR) ; Converts a VMS directory
+1 ; Input: VMSDIR - OpenVMS directory name (e.g., "USER$:[SPMP]")
+2 ;Output: $$XVMSDIR - Converted VMS directory (e.g., "/USER$/SPMP/")
+3 QUIT "/"_$TRANSLATE(VMSDIR,".[]:","///")
+4 ;
SAVEKEYS(STATE,LOCDIR) ; Saves Key, converts SSH2 to OpenSSH when running on Linux
+1 ;Input: STATE - State to retrieve the keys from
+2 ; LOCDIR - Local directory where the keys should be saved to
+3 NEW WLINE,XPV
+4 IF $$GET1^DIQ(58.41,STATE,18,"I")="SSH2"
Begin DoDot:1
+5 ;Saving the Private SSH Key
+6 DO OPEN^%ZISH("VMSSSHKEY",LOCDIR,"VMSSSHKEY","W")
+7 DO USE^%ZISUTL("VMSSSHKEY")
+8 FOR WLINE=1:1
if '$DATA(^PS(58.41,STATE,"PRVKEY",WLINE))
QUIT
Begin DoDot:2
+9 WRITE $$DECRYP^XUSRB1(^PS(58.41,STATE,"PRVKEY",WLINE,0)),!
End DoDot:2
+10 DO CLOSE^%ZISH("VMSSSHKEY")
End DoDot:1
+11 ;
+12 IF $$OS^%ZOSV()["VMS"
Begin DoDot:1
+13 ;Saving the Public SSH Key (Assuming SSH2 format) - VMS Only
+14 DO OPEN^%ZISH("VMSSSHKEY",LOCDIR,"VMSSSHKEY.PUB","W")
+15 DO USE^%ZISUTL("VMSSSHKEY")
+16 FOR WLINE=1:1
if '$DATA(^PS(58.41,STATE,"PUBKEY",WLINE))
QUIT
Begin DoDot:2
+17 WRITE $$DECRYP^XUSRB1(^PS(58.41,STATE,"PUBKEY",WLINE,0)),!
End DoDot:2
+18 DO CLOSE^%ZISH("VMSSSHKEY")
End DoDot:1
QUIT
+19 ;
+20 IF $$OS^%ZOSV()["UNIX"
Begin DoDot:1
+21 ;If Key format is SSH2, convert VMSSSHKEY to OpenSSH format; Otherwise write directly from VistA
+22 IF $$GET1^DIQ(58.41,STATE,18,"I")="SSH2"
Begin DoDot:2
+23 SET XPV="S PV=$ZF(-1,""ssh-keygen -i -f "_LOCDIR_"VMSSSHKEY > "_LOCDIR_"linuxsshkey"")"
+24 XECUTE XPV
End DoDot:2
+25 IF '$TEST
Begin DoDot:2
+26 ;Saving the Private SSH Key (OpenSSH Format)
+27 DO OPEN^%ZISH("linuxsshkey",LOCDIR,"linuxsshkey","W")
+28 DO USE^%ZISUTL("linuxsshkey")
+29 FOR WLINE=1:1
if '$DATA(^PS(58.41,STATE,"PRVKEY",WLINE))
QUIT
Begin DoDot:3
+30 WRITE $$DECRYP^XUSRB1(^PS(58.41,STATE,"PRVKEY",WLINE,0)),!
End DoDot:3
+31 DO CLOSE^%ZISH("linuxsshkey")
End DoDot:2
+32 SET XPV="S PV=$ZF(-1,""chmod 600 "_LOCDIR_"linuxsshkey"")"
+33 XECUTE XPV
End DoDot:1
QUIT
+34 ;
+35 QUIT
+36 ;
LINUXDIR() ; Returns the Linux Directory for SPMP sFTP
+1 NEW CURDIR,ROOTDIR,PSOVER
+2 IF $$OS^%ZOSV()'="UNIX"
QUIT ""
+3 SET PSOVER=$$UP^XLFSTR($$VERSION^%ZOSV(1))
+4 ;PSO*7*630
IF PSOVER'["CACHE"
IF PSOVER'["IRIS"
QUIT ""
+5 ; Retrieving the current directory
+6 XECUTE "S CURDIR=$ZU(12)"
SET ROOTDIR=$PIECE(CURDIR,"/",1,4)
+7 IF $EXTRACT(ROOTDIR,$LENGTH(ROOTDIR))="/"
SET $EXTRACT(ROOTDIR,$LENGTH(ROOTDIR))=""
+8 QUIT ROOTDIR_"/user/sftp/spmp/"
+9 ;
DIREXIST(DIR) ; Returns whether the Linux Directory for SPMP sFTP already exists
+1 ;Input: DIR - Linux Directory name to be checked
+2 NEW DIREXIST,PSOVER
+3 IF DIR=""
QUIT 0
+4 IF $$OS^%ZOSV()'="UNIX"
QUIT 0
+5 SET PSOVER=$$UP^XLFSTR($$VERSION^%ZOSV(1))
+6 ;PSO*7*630
IF PSOVER'["CACHE"
IF PSOVER'["IRIS"
QUIT 0
+7 IF $EXTRACT(DIR,$LENGTH(DIR))="/"
SET $EXTRACT(DIR,$LENGTH(DIR))=""
+8 XECUTE "S DIREXIST=$ZSEARCH(DIR)"
+9 QUIT $SELECT(DIREXIST="":0,1:1)
+10 ;
MAKEDIR(DIR) ; Create a new directory
+1 ;Input: DIR - Linux Directory name to be created
+2 NEW MKDIR,PSOVER
+3 IF $$OS^%ZOSV()'="UNIX"
QUIT
+4 SET PSOVER=$$UP^XLFSTR($$VERSION^%ZOSV(1))
+5 ;PSO*7*630
IF PSOVER'["CACHE"
IF PSOVER'["IRIS"
QUIT
+6 IF $$DIREXIST(DIR)
QUIT
+7 XECUTE "S MKDIR=$ZF(-1,""mkdir ""_DIR)"
+8 IF 'MKDIR
XECUTE "S MKDIR=$ZF(-1,""chmod 777 ""_DIR)"
+9 QUIT
+10 ;
SETLN(NSPC,TEXT,REV,UND,HIG) ; Sets a line to be displayed in the Body section
+1 ;Input: NSPC - Namespace of the ^TMP global
+2 ; TEXT - Line of text to be added to Listman
+3 ; REV - Reverse video (1: YES / 0:NO)
+4 ; UND - Underlined (1: YES / 0: NO)
+5 ; HIG - Highlighted (1: YES / 0: NO)
+6 NEW X
+7 if $GET(TEXT)=""
SET $EXTRACT(TEXT,80)=""
+8 if $LENGTH(TEXT)>80
SET TEXT=$EXTRACT(TEXT,1,80)
+9 SET LINE=LINE+1
SET ^TMP(NSPC,$JOB,LINE,0)=$GET(TEXT)
+10 ;
+11 IF LINE>$GET(PSOLSTLN)
DO SAVE^VALM10(LINE)
SET PSOLSTLN=LINE
+12 ;
+13 IF $GET(REV)
Begin DoDot:1
+14 DO CNTRL^VALM10(LINE,1,$LENGTH(TEXT),IORVON,IORVOFF_IOINORM)
+15 IF $GET(UND)
DO CNTRL^VALM10(LINE,$LENGTH(TEXT)+1,80,IOUON,IOINORM)
End DoDot:1
QUIT
+16 IF $GET(UND)
DO CNTRL^VALM10(LINE,1,80,IOUON,IOINORM)
+17 IF $GET(HIG)
Begin DoDot:1
+18 DO CNTRL^VALM10(LINE,HIG,80,IOINHI_$SELECT($GET(UND):IOUON,1:""),IOINORM)
End DoDot:1
+19 QUIT
