APSSSPRO.m

APSSSPRO ;IHS/CIA/PLS - ScriptPro Interface;08-Mar-2012 16:37;PLS

 ;;1.0;IHS SCRIPTPRO INTERFACE;**1**;January 11, 2006;Build 13

 ;Call via entry point placed in Field 900 of File 9009033

 ;Direct entry not supported

 ; Modified - IHS/MSC/PLS - 02/08/07 - Line ASK+2 - Added check for ZTSK

 ;                          12/06/07 - Line ASK+7 - Changed duplicate check for DTOUT to check for DUOUT

 Q

EP1(RXIEN,REPRINT,SGY,RXF,RXPI) ;PEP	- Main entry point

 N APSS,RX0,RX2,RX3,REFIEN,RXSTAT,QTY

 N DEVLP

 Q:'$G(RXIEN)  ; Prescription IEN required

 Q:'$D(^APSSPARM($G(DUZ(2))))

 Q:'$$SETUP(DUZ(2),.APSS)

TASK ;

 I $G(APSS("ASK")),'$$ASK("Send to SCRIPT-PRO") U IO Q

 Q:'$G(APSS("DEV"))  ; No device

 ;S DEVLP=0

 ;F  S DEVLP=$O(APSS("DEV",DEVLP)) Q:'DEVLP  D

 ;.

 N ZTRTN,ZTIO,ZTDESC,ZTREQ,ZTSAVE,VAR,ZTSK

 ;.

 ;S DEV=$P(APSS("DEV",DEVLP),U,2)

 ;.Q:'DEV  ;No device specified

 S ZTRTN="EPTASK^APSSSPRO"

 S ZTDESC="ScriptPro Interface for RXIEN: "_RXIEN

 S ZTDTH=$H

 S ZTIO="`"_APSS("DEV")

 F VAR="RXIEN","REPRINT","SGY(","RXF","RXPI","PSOSITE" S:$D(VAR) ZTSAVE(VAR)=""

 D ^%ZTLOAD

 Q

 ;

EPTASK ;EP - Tasked entry point

 Q:'$$SETUP(DUZ(2),.APSS)

 D INIT

 ;

 Q:'$$DRUGOK($$GETP(RX0,6))

 ;

 ; Build output from Table

 S APSSREC=""

 S APSSCMD=$$FIND1^DIC(9009033.3,,,"FILL")

 Q:'APSSCMD

 D BLDFARY(.APSSFARY,APSSCMD)

 ;

 D SETRM(0)

 U IO W $$PROCARY(APSSCMD,.APSSFARY,.APSSREC)

 D:APSS("LOG") LOG(APSSREC,.SGY)

 Q

 ; Build field array

BLDFARY(ARY,CIEN) ;

 N IEN,SEQ

 S IEN=0

 F  S IEN=$O(^APSSCOMD(CIEN,1,IEN)) Q:'IEN  D

 .S SEQ=+$P($G(^APSSCOMD(CIEN,1,IEN,0)),U,2)

 .S:SEQ>0 ARY(SEQ)=IEN

 Q

 ; Initialize output array

PROCARY(CIEN,FLDS,RET) ;

 N LP,VNM

 D ADD("|**|<COMMAND>FILL")

 S LP=0 F  S LP=$O(FLDS(LP)) Q:'LP  D

 .S VNM=$P(^APSSCOMD(CIEN,1,FLDS(LP),0),U)

 .D ADD("<"_VNM_">"_$$DATA(CIEN,FLDS(LP),RXIENS))

 D ADD("|##|"_$C(13,10))

 Q RET

 ; Return data for given tag

DATA(CMDIEN,TAGIEN,RXIENS) ;

 N TAG0,FILE,FLD

 S TAG0=$G(^APSSCOMD(CMDIEN,1,TAGIEN,0))

 S FILE=$P($P(TAG0,U,3),",")

 S FLD=$P($P(TAG0,U,3),",",2)

 S FMT=$P(TAG0,U,4)

 I $L(RXIENS,",")>2 D

 .S RXIENS=$S($F(FMT,"R"):RXIENS,1:$P(RXIENS,",",2)_",")

 S VAL=""

 I FILE,FLD D

 .S VAL=$$GET1^DIQ(FILE,RXIENS,FLD,$S(FMT["I":"I",1:"E"))

 ; Check for Transform code

 I $F(FMT,"Z")>0 D

 .X:$L($G(^APSSCOMD(CMDIEN,1,TAGIEN,1))) ^APSSCOMD(CMDIEN,1,TAGIEN,1)

 ; Check for Date Format

 I $F(FMT,"D")>0 D

 .S FMTD=$E(FMT,$F(FMT,"D"))

 .S VAL=$TR($$FMTE^XLFDT(VAL,$S(FMTD=2:"7",1:"5")_"Z"),"/","")

 .S:FMTD=3 VAL=$E(VAL,1,2)_$E(VAL,5,8)

 Q VAL

 ; Add a node to the output array

ADD(VAL) ;

 S RET=$G(RET,"")_VAL

 Q

SETUP(FAC,APSS) ;EP - Build configuration array

 N PARAM,DEVLP,CNT,DAT

 S APSS("PFL")="N"

 S (PARAM,APSS("PARM"))=$G(^APSSPARM(FAC,0))

 Q:'PARAM 0

 Q:'$$GETP(PARAM,2) 0   ; Interface is turned off

 S APSS("DEV")=$$GETDEV(+$G(PSOSITE),+$$GETP(PARAM,3))

 S APSS("SIGLINE")=$S($$GETP(PARAM,4):$$GETP(PARAM,4),1:30)

 S APSS("CHKDRG")=''$$GETP(PARAM,5)

 S APSS("ASK")=''$$GETP(PARAM,6)

 S APSS("LOG")=''$$GETP(PARAM,7)

 Q 1

 ;S CNT=1

 ;S APSS("DEV",CNT)=U_$$GETP(PARAM,3)

 ;S DEVLP=0

 ;F  S DEVLP=$O(^APSSPARM(FAC,2,DEVLP)) Q:'DEVLP  D

 ;.S DAT=^APSSPARM(FAC,2,DEVLP,0)

 .Q:'$P(DAT,U,3)  ;Is device active?

 ;.S CNT=CNT+1

 ;.S APSS("DEV",CNT)=DAT

 ;Q 1

 ;

INIT ;EP - Build data for prescription

 S RX0=$G(^PSRX(RXIEN,0))

 S RX2=$G(^PSRX(RXIEN,2))

 S RX3=$G(^PSRX(RXIEN,3))

 S RXSTAT=$G(^PSRX(RXIEN,"STA"))

 S PARIEN=+$G(RXPI)

 ;S REFIEN=+$O(^PSRX(RXIEN,1,$C(1)),-1)

 S REFIEN=+$G(RXF)

 S QTY=+$S(PARIEN:$P($G(^PSRX(RXIEN,"P",PARIEN,0)),U,4),REFIEN:$P($G(^PSRX(RXIEN,1,REFIEN,0)),U,4),1:$P(RX0,U,7))

 S RXIENS=$S(PARIEN:PARIEN_",",REFIEN:REFIEN_",",1:"")_RXIEN_","

 Q

 ; Log transmission

LOG(REC,SGY) ;

 N APSSNOW,LP

 S APSSNOW=$$NOW^XLFDT

 L +^XTMP("APSSSPRO"):2

 S ^XTMP("APSSSPRO",0)=$$FMADD^XLFDT(DT,7)_U_$$DT^XLFDT

 S ^XTMP("APSSSPRO",RXIEN,APSSNOW)=REC

 S LP=0 F  S LP=$O(SGY(LP)) Q:'LP  S ^XTMP("APSSSPRO",RXIEN,APSSNOW,LP)=SGY(LP)

 L -^XTMP("APSSSPRO")

 Q

 ; Check drug availability in ScriptPro

DRUGOK(DRUGIEN) ;EP

 I 'APSS("CHKDRG") Q 1    ; Drug checking is disabled

 N PARAM

 S PARAM=$G(^APSSDRUG(DRUGIEN,0))

 Q:'$$GETP(PARAM,1) 0     ; Drug not present

 Q:'$$GETP(PARAM,3) 1     ; Inactive date not present

 I $$GETP(PARAM,3)<$$FMADD^XLFDT(DT,1) Q 0    ; Drug has been deactivated

 Q '(QTY>$$GETP(PARAM,2))    ; Quantity

 ;

CHKDRUG(RXIEN) ; PEP - Logic called from field 800 in APSP Control file

 N APSS,RX0,RX2,RX3,REFIEN,RXSTAT,QTY

 Q:'$$SETUP($G(DUZ(2)),.APSS) 0

 D INIT

 Q $$DRUGOK($$GETP(RX0,6))

 ; Returns given piece of supplied string

GETP(VAL,P) ;EP

 Q $P(VAL,U,P)

SIG() ;

 S APSS("SIG")=""

 S N=0

 F  S N=$O(SGY(N)) Q:'N  D

 .I APSS("SIG")="" S APSS("SIG")=SGY(N) Q

 .S APSS("SIG")=APSS("SIG")_SGY(N)

 Q:$Q APSS("SIG")

 Q

 ; Return priority

GETPRI(LOCIEN) ;EP

 Q:'$G(LOCIEN) 0

 Q $S($D(^APSSPARM(DUZ(2),1,LOCIEN,0)):+$$GETP(^APSSPARM(DUZ(2),1,LOCIEN,0),2),1:1)

 ;

ASK(PRMPT) ;EP - Prompt user for transmission to ScriptPro

 N DIR,DTOUT,DUOUT

 I $E(IOST,1)="P"!$G(ZTSK) Q 1  ; User input not available for queued tasks or print devices

 S DIR("A")=PRMPT  ;"Send to SCRIPT-PRO"

 S DIR("B")="N"

 S DIR(0)="Y"

 D ^DIR

 Q:$D(DTOUT)!($D(DUOUT)) 0

 Q Y>0

 ; Query for drug

HASDRUG(DRUG) ; EP

 Q:'$G(DRUG) 0

 Q ''$D(^APSSDRUG(DRUG))

 ; Set Right Margin of output device

SETRM(X) ;

 X ^%ZOSF("RM")

 Q

 ; Return device for pharmacy division or default

GETDEV(PDIV,DEF) ;EP-

 N PDIEN

 S PDIEN=$O(^APSSPARM(FAC,2,"B",+$G(PDIV),0))

 Q:'PDIEN DEF

 S DAT=$G(^APSSPARM(FAC,2,PDIEN,0))

 Q $S($P(DAT,U,3)&$P(DAT,U,2):$P(DAT,U,2),1:DEF)

APSSSPRO  ;IHS/CIA/PLS - ScriptPro Interface;08-Mar-2012 16:37;PLS

 +1       ;;1.0;IHS SCRIPTPRO INTERFACE;**1**;January 11, 2006;Build 13

 +2       ;Call via entry point placed in Field 900 of File 9009033

 +3       ;Direct entry not supported

 +4       ; Modified - IHS/MSC/PLS - 02/08/07 - Line ASK+2 - Added check for ZTSK

 +5       ;                          12/06/07 - Line ASK+7 - Changed duplicate check for DTOUT to check for DUOUT

 +6        QUIT 

EP1(RXIEN,REPRINT,SGY,RXF,RXPI) ;PEP	- Main entry point

 +1        NEW APSS,RX0,RX2,RX3,REFIEN,RXSTAT,QTY

 +2        NEW DEVLP

 +3       ; Prescription IEN required

           IF '$GET(RXIEN)

               QUIT 

 +4        IF '$DATA(^APSSPARM($GET(DUZ(2))))

               QUIT 

 +5        IF '$$SETUP(DUZ(2),.APSS)

               QUIT 

TASK      ;

 +1        IF $GET(APSS("ASK"))

               IF '$$ASK("Send to SCRIPT-PRO")

                   USE IO

                   QUIT 

 +2       ; No device

           IF '$GET(APSS("DEV"))

               QUIT 

 +3       ;S DEVLP=0

 +4       ;F  S DEVLP=$O(APSS("DEV",DEVLP)) Q:'DEVLP  D

 +5       ;.

 +6        NEW ZTRTN,ZTIO,ZTDESC,ZTREQ,ZTSAVE,VAR,ZTSK

 +7       ;.

 +8       ;S DEV=$P(APSS("DEV",DEVLP),U,2)

 +9       ;.Q:'DEV  ;No device specified

 +10       SET ZTRTN="EPTASK^APSSSPRO"

 +11       SET ZTDESC="ScriptPro Interface for RXIEN: "_RXIEN

 +12       SET ZTDTH=$HOROLOG

 +13       SET ZTIO="`"_APSS("DEV")

 +14       FOR VAR="RXIEN","REPRINT","SGY(","RXF","RXPI","PSOSITE"

               IF $DATA(VAR)

                   SET ZTSAVE(VAR)=""

 +15       DO ^%ZTLOAD

 +16       QUIT 

 +17      ;

EPTASK    ;EP - Tasked entry point

 +1        IF '$$SETUP(DUZ(2),.APSS)

               QUIT 

 +2        DO INIT

 +3       ;

 +4        IF '$$DRUGOK($$GETP(RX0,6))

               QUIT 

 +5       ;

 +6       ; Build output from Table

 +7        SET APSSREC=""

 +8        SET APSSCMD=$$FIND1^DIC(9009033.3,,,"FILL")

 +9        IF 'APSSCMD

               QUIT 

 +10       DO BLDFARY(.APSSFARY,APSSCMD)

 +11      ;

 +12       DO SETRM(0)

 +13       USE IO

           WRITE $$PROCARY(APSSCMD,.APSSFARY,.APSSREC)

 +14       IF APSS("LOG")

               DO LOG(APSSREC,.SGY)

 +15       QUIT 

 +16      ; Build field array

BLDFARY(ARY,CIEN) ;

 +1        NEW IEN,SEQ

 +2        SET IEN=0

 +3        FOR 

               SET IEN=$ORDER(^APSSCOMD(CIEN,1,IEN))

               IF 'IEN

                   QUIT 

               Begin DoDot:1

 +4                SET SEQ=+$PIECE($GET(^APSSCOMD(CIEN,1,IEN,0)),U,2)

 +5                IF SEQ>0

                       SET ARY(SEQ)=IEN

               End DoDot:1

 +6        QUIT 

 +7       ; Initialize output array

PROCARY(CIEN,FLDS,RET) ;

 +1        NEW LP,VNM

 +2        DO ADD("|**|<COMMAND>FILL")

 +3        SET LP=0

           FOR 

               SET LP=$ORDER(FLDS(LP))

               IF 'LP

                   QUIT 

               Begin DoDot:1

 +4                SET VNM=$PIECE(^APSSCOMD(CIEN,1,FLDS(LP),0),U)

 +5                DO ADD("<"_VNM_">"_$$DATA(CIEN,FLDS(LP),RXIENS))

               End DoDot:1

 +6        DO ADD("|##|"_$CHAR(13,10))

 +7        QUIT RET

 +8       ; Return data for given tag

DATA(CMDIEN,TAGIEN,RXIENS) ;

 +1        NEW TAG0,FILE,FLD

 +2        SET TAG0=$GET(^APSSCOMD(CMDIEN,1,TAGIEN,0))

 +3        SET FILE=$PIECE($PIECE(TAG0,U,3),",")

 +4        SET FLD=$PIECE($PIECE(TAG0,U,3),",",2)

 +5        SET FMT=$PIECE(TAG0,U,4)

 +6        IF $LENGTH(RXIENS,",")>2

               Begin DoDot:1

 +7                SET RXIENS=$SELECT($FIND(FMT,"R"):RXIENS,1:$PIECE(RXIENS,",",2)_",")

               End DoDot:1

 +8        SET VAL=""

 +9        IF FILE

               IF FLD

                   Begin DoDot:1

 +10                   SET VAL=$$GET1^DIQ(FILE,RXIENS,FLD,$SELECT(FMT["I":"I",1:"E"))

                   End DoDot:1

 +11      ; Check for Transform code

 +12       IF $FIND(FMT,"Z")>0

               Begin DoDot:1

 +13               IF $LENGTH($GET(^APSSCOMD(CMDIEN,1,TAGIEN,1)))

                       XECUTE ^APSSCOMD(CMDIEN,1,TAGIEN,1)

               End DoDot:1

 +14      ; Check for Date Format

 +15       IF $FIND(FMT,"D")>0

               Begin DoDot:1

 +16               SET FMTD=$EXTRACT(FMT,$FIND(FMT,"D"))

 +17               SET VAL=$TRANSLATE($$FMTE^XLFDT(VAL,$SELECT(FMTD=2:"7",1:"5")_"Z"),"/","")

 +18               IF FMTD=3

                       SET VAL=$EXTRACT(VAL,1,2)_$EXTRACT(VAL,5,8)

               End DoDot:1

 +19       QUIT VAL

 +20      ; Add a node to the output array

ADD(VAL)  ;

 +1        SET RET=$GET(RET,"")_VAL

 +2        QUIT 

SETUP(FAC,APSS) ;EP - Build configuration array

 +1        NEW PARAM,DEVLP,CNT,DAT

 +2        SET APSS("PFL")="N"

 +3        SET (PARAM,APSS("PARM"))=$GET(^APSSPARM(FAC,0))

 +4        IF 'PARAM

               QUIT 0

 +5       ; Interface is turned off

           IF '$$GETP(PARAM,2)

               QUIT 0

 +6        SET APSS("DEV")=$$GETDEV(+$GET(PSOSITE),+$$GETP(PARAM,3))

 +7        SET APSS("SIGLINE")=$SELECT($$GETP(PARAM,4):$$GETP(PARAM,4),1:30)

 +8        SET APSS("CHKDRG")=''$$GETP(PARAM,5)

 +9        SET APSS("ASK")=''$$GETP(PARAM,6)

 +10       SET APSS("LOG")=''$$GETP(PARAM,7)

 +11       QUIT 1

 +12      ;S CNT=1

 +13      ;S APSS("DEV",CNT)=U_$$GETP(PARAM,3)

 +14      ;S DEVLP=0

 +15      ;F  S DEVLP=$O(^APSSPARM(FAC,2,DEVLP)) Q:'DEVLP  D

 +16      ;.S DAT=^APSSPARM(FAC,2,DEVLP,0)

 +17      ;Is device active?