PSSXDIC.m

PSSXDIC ;;OIFIO BAY PINES/ELR - UPDATE DESCRIPTION OF FILE 54 - 3/2/2004

 ;;1.0; PHARMACY DATA MANAGEMENT;**84**;9/30/97

 Q

START ;

 I '$D(^PS(54,"B","NO TRANSFER")) D ZTQUE Q

 S DA=$O(^PS(54,"B","NO TRANSFER",0))

 I 'DA D ZTQUE Q

 NEW PSSDA,PSSDIC,PSSI,PSSIENS,FDA

 S PSSDIC(1)="CAUTION: Federal law prohibits the"

 S PSSDIC(2)="transfer of this drug to any person"

 S PSSDIC(3)="other than the patient for whom it"

 S PSSDIC(4)="was prescribed."

 LOCK +^PS(54,DA)

 F PSSI=1:1:4 D

 .S PSSDA=PSSI_","_DA

 .D FDA

 .D SET

 LOCK -^PS(54,DA)

 K DA,XMDUZ

 Q

FDA ;

 S PSSIENS=$$IENS^DILF(.PSSDA)

 D FDA^DILF(54.1,PSSIENS,.01,"",PSSDIC(PSSI),"FDA(54)")

 Q

SET D FILE^DIE("","FDA(54)","PSSIENS")

 I $G(^TMP("DIERR",$J,1)) D ZTQUE

 Q

BULL ; Bulletin for failed update

 N PSSLN,PSSMSG S PSSLN=0

 K ^TMP("PSSDIC",$J)

 S XMSUB="DICITONARY MAINTENANCE (FILE 54) " K XMY

 S XMTEXT="^TMP(""PSSDIC"",$J,"

 S XMY($S(DUZ:DUZ,1:.5))=""

 S XMDUZ=.5 D NOW^%DTC

 S PSSMSG=" " D SETLN

 S PSSMSG="The update of file RX CONSULT, NO TRANSFER description failed." D SETLN

 S PSSMSG=" " D SETLN

 D ^XMD

 K ^TMP("PSSDIC",$J),XMY,XMTEXT,XMSUB

 Q

SETLN ; Setting TMP global for bulletin

 S PSSLN=PSSLN+1

 S ^TMP("PSSDIC",$J,PSSLN)=PSSMSG

 Q

ZTQUE   ;

 N ZTIO,ZTDTH,ZTDESC,ZTRTN,ZTSAVE

 S ZTIO="",ZTDTH=$H,$P(ZTDTH,",",2)=$P(ZTDTH,",",2)+60,ZTDESC="PDM UPDATE ERROR"

 S ZTRTN="BULL^PSSXDIC"

 D ^%ZTLOAD

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PSSXDIC   1424     printed  Mar 13, 2025@21:39:26                                                                                                                                                                                                     Page 2

PSSXDIC   ;;OIFIO BAY PINES/ELR - UPDATE DESCRIPTION OF FILE 54 - 3/2/2004

 +1       ;;1.0; PHARMACY DATA MANAGEMENT;**84**;9/30/97

 +2        QUIT 

START     ;

 +1        IF '$DATA(^PS(54,"B","NO TRANSFER"))

               DO ZTQUE

               QUIT 

 +2        SET DA=$ORDER(^PS(54,"B","NO TRANSFER",0))

 +3        IF 'DA

               DO ZTQUE

               QUIT 

 +4        NEW PSSDA,PSSDIC,PSSI,PSSIENS,FDA

 +5        SET PSSDIC(1)="CAUTION: Federal law prohibits the"

 +6        SET PSSDIC(2)="transfer of this drug to any person"

 +7        SET PSSDIC(3)="other than the patient for whom it"

 +8        SET PSSDIC(4)="was prescribed."

 +9        LOCK +^PS(54,DA)

 +10       FOR PSSI=1:1:4

               Begin DoDot:1

 +11               SET PSSDA=PSSI_","_DA

 +12               DO FDA

 +13               DO SET

               End DoDot:1

 +14       LOCK -^PS(54,DA)

 +15       KILL DA,XMDUZ

 +16       QUIT 

FDA       ;

 +1        SET PSSIENS=$$IENS^DILF(.PSSDA)

 +2        DO FDA^DILF(54.1,PSSIENS,.01,"",PSSDIC(PSSI),"FDA(54)")

 +3        QUIT 

SET        DO FILE^DIE("","FDA(54)","PSSIENS")

 +1        IF $GET(^TMP("DIERR",$JOB,1))

               DO ZTQUE

 +2        QUIT 

BULL      ; Bulletin for failed update

 +1        NEW PSSLN,PSSMSG

           SET PSSLN=0

 +2        KILL ^TMP("PSSDIC",$JOB)

 +3        SET XMSUB="DICITONARY MAINTENANCE (FILE 54) "

           KILL XMY

 +4        SET XMTEXT="^TMP(""PSSDIC"",$J,"

 +5        SET XMY($SELECT(DUZ:DUZ,1:.5))=""

 +6        SET XMDUZ=.5

           DO NOW^%DTC

 +7        SET PSSMSG=" "

           DO SETLN

 +8        SET PSSMSG="The update of file RX CONSULT, NO TRANSFER description failed."

           DO SETLN

 +9        SET PSSMSG=" "

           DO SETLN

 +10       DO ^XMD

 +11       KILL ^TMP("PSSDIC",$JOB),XMY,XMTEXT,XMSUB

 +12       QUIT 

SETLN     ; Setting TMP global for bulletin

 +1        SET PSSLN=PSSLN+1

 +2        SET ^TMP("PSSDIC",$JOB,PSSLN)=PSSMSG

 +3        QUIT 

ZTQUE     ;

 +1        NEW ZTIO,ZTDTH,ZTDESC,ZTRTN,ZTSAVE

 +2        SET ZTIO=""

           SET ZTDTH=$HOROLOG

           SET $PIECE(ZTDTH,",",2)=$PIECE(ZTDTH,",",2)+60

           SET ZTDESC="PDM UPDATE ERROR"

 +3        SET ZTRTN="BULL^PSSXDIC"

 +4        DO ^%ZTLOAD

 +5        QUIT