- PSOHCPRS ;BIR/RTR-Put CHCS message in Pending File and process ;07/02/02
- ;;7.0;OUTPATIENT PHARMACY;**111**;DEC 1997
- ;External reference to ^DG(40.8 supported by DBIA 728
- ;External reference to ^SC( supported by DBIA 2675
- ;
- ADD ;Add CHCS message to Outpatient Pending Orders file
- N PSOHQ,PSOHQT,PSOCPEND,PSOHINI,PSOHINLO
- S (PSOHINI,PSOHINLO)=0 D
- .I $G(PSOHY("LOC")) S PSOHINLO=$P($G(^SC(PSOHY("LOC"),0)),"^",4) I PSOHINLO Q
- .I $G(PSOHY("LOC")) S PSOHINI=$P($G(^SC(PSOHY("LOC"),0)),"^",15)
- .I '$G(PSOHINI) S PSOHINI=$O(^DG(40.8,0))
- .S PSOHINLO=+$$SITE^VASITE(PSOHINI)
- I +$G(PSOHINLO)<0 S PSOEXMS="Unable to derive Institution from CLinic." D NAK^PSOHLEXC Q
- K DD,DO,DIC S X=PSOHY("CHNUM"),DIC="^PS(52.41,",DIC(0)="L"
- S:$G(PSOHY("PICK"))="" PSOHY("PICK")="W"
- S DIC("DR")="4////"_$G(PSOHY("ENTER"))_";5////"_PSOHY("PROV")_";6////"_$G(PSOHY("SDT"))_";8////"_PSOHY("ITEM")_";11////"_PSOHY("DRUG")_";12////"_$G(PSOHY("QTY"))_";13////"_$G(PSOHY("REF"))
- D FILE^DICN K DD,DIC,DO I Y<0 S PSOEXMS="Unable to add order to Pending file." D NAK^PSOHLEXC Q
- S PSOCPEND=+Y
- S $P(^PS(52.41,PSOCPEND,0),"^",2)=PSOHY("PAT"),$P(^(0),"^",3)=PSOHY("OCC"),$P(^(0),"^",12)=$G(PSOHY("EDT")),$P(^(0),"^",13)=PSOHY("LOC")
- S $P(^PS(52.41,PSOCPEND,0),"^",14)=$G(PSOHY("PRIOR")),$P(^(0),"^",17)=$G(PSOHY("PICK"))
- S $P(^PS(52.41,PSOCPEND,"EXT"),"^")=PSOHY("CHNUM"),$P(^("EXT"),"^",2)=0,$P(^("EXT"),"^",3)=PSOHY("EXAPP")
- N DA,DIK S DA=PSOCPEND,DIK="^PS(52.41,",DIK(1)="114^C" D EN1^DIK
- I $O(PSOHY("PRCOM",0)) D I PSOHQT S ^PS(52.41,PSOCPEND,3,0)="^^"_PSOHQT_"^"_PSOHQT_"^"_DT_"^"
- .S PSOHQ="",PSOHQT=0 F S PSOHQ=$O(PSOHY("PRCOM",PSOHQ)) Q:PSOHQ="" I $G(PSOHY("PRCOM",PSOHQ))'="" S PSOHQT=PSOHQT+1,^PS(52.41,PSOCPEND,3,PSOHQT,0)=$G(PSOHY("PRCOM",PSOHQ))
- I $O(PSOHY("SIG",0)) D I PSOHQT S ^PS(52.41,PSOCPEND,"SIG",0)="^52.4124A^"_PSOHQT_"^"_PSOHQT
- .S PSOHQ="",PSOHQT=0 F S PSOHQ=$O(PSOHY("SIG",PSOHQ)) Q:PSOHQ="" I $G(PSOHY("SIG",PSOHQ))'="" S PSOHQT=PSOHQT+1,^PS(52.41,PSOCPEND,"SIG",PSOHQT,0)=$G(PSOHY("SIG",PSOHQ))
- S $P(^PS(52.41,PSOCPEND,"INI"),"^")=$G(PSOHINLO)
- ;Cross references not set yet preventing Pharmacy from finishing order
- D EN^PSOHLSNC(PSOCPEND,"SN","IP")
- ;Just set to DC, don't delete because 52.41 entry would be re-used
- ;I '$P($G(^PS(52.41,PSOCPEND,"EXT")),"^",2) S DA=PSOCPEND,DIK="^PS(52.41," D ^DIK K DIK,DA S PSOEXMS="Unable to send CHCS order to CPRS." D NAK^PSOHLEXC Q
- I '$P($G(^PS(52.41,PSOCPEND,"EXT")),"^",2) D S $P(^PS(52.41,PSOCPEND,0),"^",3)="DC" S PSOEXMS="Unable to send CHCS order to CPRS." D NAK^PSOHLEXC Q
- .;x-ref shouldn't be set, but we'll kill them just in case
- .K ^PS(52.41,"AOR",$P(^PS(52.41,PSOCPEND,0),"^",2),+$P($G(^("INI")),"^"),PSOCPEND),^PS(52.41,"AD",$P(^PS(52.41,PSOCPEND,0),"^",12),+$P($G(^("INI")),"^"),PSOCPEND)
- .K ^PS(52.41,"ACL",+$P(^PS(52.41,PSOCPEND,0),"^",13),$P(^(0),"^",12),PSOCPEND),^PS(52.41,"AQ",+$P($G(^PS(52.41,PSOCPEND,0)),"^",21),PSOCPEND)
- .S $P(^PS(52.41,PSOCPEND,4),"^")="External order, unable to successfully transmit to CPRS."
- ;Successful transmission to CPRS
- S DA=PSOCPEND,DIK="^PS(52.41," D IX^DIK
- Q
- SIGS ;
- N PSOHZZZ,PSOHZZZZ
- S PSOHZZZ=1,PSOHZZZZ=""
- F S PSOHZZZZ=$O(^PS(52.41,ORD,"SIG",PSOHZZZZ)) Q:PSOHZZZZ="" I $D(^(PSOHZZZZ,0)) S SIG(PSOHZZZ)=$G(^(0)),PSOHZZZ=PSOHZZZ+1
- I $O(PSONEW("SIG",""))'="" S PSOHZZZZ="" F S PSOHZZZZ=$O(PSONEW("SIG",PSOHZZZZ)) Q:PSOHZZZZ="" S SIG(PSOHZZZ)=$G(PSONEW("SIG",PSOHZZZZ)),PSOHZZZ=PSOHZZZ+1
- I $O(PSONEW("SIG",""))'="" Q
- I $O(PRC(""))'="" S PSOHZZZZ="" F S PSOHZZZZ=$O(PRC(PSOHZZZZ)) Q:PSOHZZZZ="" I $D(PRC(PSOHZZZZ)) S SIG(PSOHZZZ)=$G(PRC(PSOHZZZZ)),PSOHZZZ=PSOHZZZ+1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOHCPRS 3645 printed Jan 18, 2025@03:30:42 Page 2
- PSOHCPRS ;BIR/RTR-Put CHCS message in Pending File and process ;07/02/02
- +1 ;;7.0;OUTPATIENT PHARMACY;**111**;DEC 1997
- +2 ;External reference to ^DG(40.8 supported by DBIA 728
- +3 ;External reference to ^SC( supported by DBIA 2675
- +4 ;
- ADD ;Add CHCS message to Outpatient Pending Orders file
- +1 NEW PSOHQ,PSOHQT,PSOCPEND,PSOHINI,PSOHINLO
- +2 SET (PSOHINI,PSOHINLO)=0
- Begin DoDot:1
- +3 IF $GET(PSOHY("LOC"))
- SET PSOHINLO=$PIECE($GET(^SC(PSOHY("LOC"),0)),"^",4)
- IF PSOHINLO
- QUIT
- +4 IF $GET(PSOHY("LOC"))
- SET PSOHINI=$PIECE($GET(^SC(PSOHY("LOC"),0)),"^",15)
- +5 IF '$GET(PSOHINI)
- SET PSOHINI=$ORDER(^DG(40.8,0))
- +6 SET PSOHINLO=+$$SITE^VASITE(PSOHINI)
- End DoDot:1
- +7 IF +$GET(PSOHINLO)<0
- SET PSOEXMS="Unable to derive Institution from CLinic."
- DO NAK^PSOHLEXC
- QUIT
- +8 KILL DD,DO,DIC
- SET X=PSOHY("CHNUM")
- SET DIC="^PS(52.41,"
- SET DIC(0)="L"
- +9 if $GET(PSOHY("PICK"))=""
- SET PSOHY("PICK")="W"
- +10 SET DIC("DR")="4////"_$GET(PSOHY("ENTER"))_";5////"_PSOHY("PROV")_";6////"_$GET(PSOHY("SDT"))_";8////"_PSOHY("ITEM")_";11////"_PSOHY("DRUG")_";12////"_$GET(PSOHY("QTY"))_";13////"_$GET(PSOHY("REF"))
- +11 DO FILE^DICN
- KILL DD,DIC,DO
- IF Y<0
- SET PSOEXMS="Unable to add order to Pending file."
- DO NAK^PSOHLEXC
- QUIT
- +12 SET PSOCPEND=+Y
- +13 SET $PIECE(^PS(52.41,PSOCPEND,0),"^",2)=PSOHY("PAT")
- SET $PIECE(^(0),"^",3)=PSOHY("OCC")
- SET $PIECE(^(0),"^",12)=$GET(PSOHY("EDT"))
- SET $PIECE(^(0),"^",13)=PSOHY("LOC")
- +14 SET $PIECE(^PS(52.41,PSOCPEND,0),"^",14)=$GET(PSOHY("PRIOR"))
- SET $PIECE(^(0),"^",17)=$GET(PSOHY("PICK"))
- +15 SET $PIECE(^PS(52.41,PSOCPEND,"EXT"),"^")=PSOHY("CHNUM")
- SET $PIECE(^("EXT"),"^",2)=0
- SET $PIECE(^("EXT"),"^",3)=PSOHY("EXAPP")
- +16 NEW DA,DIK
- SET DA=PSOCPEND
- SET DIK="^PS(52.41,"
- SET DIK(1)="114^C"
- DO EN1^DIK
- +17 IF $ORDER(PSOHY("PRCOM",0))
- Begin DoDot:1
- +18 SET PSOHQ=""
- SET PSOHQT=0
- FOR
- SET PSOHQ=$ORDER(PSOHY("PRCOM",PSOHQ))
- if PSOHQ=""
- QUIT
- IF $GET(PSOHY("PRCOM",PSOHQ))'=""
- SET PSOHQT=PSOHQT+1
- SET ^PS(52.41,PSOCPEND,3,PSOHQT,0)=$GET(PSOHY("PRCOM",PSOHQ))
- End DoDot:1
- IF PSOHQT
- SET ^PS(52.41,PSOCPEND,3,0)="^^"_PSOHQT_"^"_PSOHQT_"^"_DT_"^"
- +19 IF $ORDER(PSOHY("SIG",0))
- Begin DoDot:1
- +20 SET PSOHQ=""
- SET PSOHQT=0
- FOR
- SET PSOHQ=$ORDER(PSOHY("SIG",PSOHQ))
- if PSOHQ=""
- QUIT
- IF $GET(PSOHY("SIG",PSOHQ))'=""
- SET PSOHQT=PSOHQT+1
- SET ^PS(52.41,PSOCPEND,"SIG",PSOHQT,0)=$GET(PSOHY("SIG",PSOHQ))
- End DoDot:1
- IF PSOHQT
- SET ^PS(52.41,PSOCPEND,"SIG",0)="^52.4124A^"_PSOHQT_"^"_PSOHQT
- +21 SET $PIECE(^PS(52.41,PSOCPEND,"INI"),"^")=$GET(PSOHINLO)
- +22 ;Cross references not set yet preventing Pharmacy from finishing order
- +23 DO EN^PSOHLSNC(PSOCPEND,"SN","IP")
- +24 ;Just set to DC, don't delete because 52.41 entry would be re-used
- +25 ;I '$P($G(^PS(52.41,PSOCPEND,"EXT")),"^",2) S DA=PSOCPEND,DIK="^PS(52.41," D ^DIK K DIK,DA S PSOEXMS="Unable to send CHCS order to CPRS." D NAK^PSOHLEXC Q
- +26 IF '$PIECE($GET(^PS(52.41,PSOCPEND,"EXT")),"^",2)
- Begin DoDot:1
- +27 ;x-ref shouldn't be set, but we'll kill them just in case
- +28 KILL ^PS(52.41,"AOR",$PIECE(^PS(52.41,PSOCPEND,0),"^",2),+$PIECE($GET(^("INI")),"^"),PSOCPEND),^PS(52.41,"AD",$PIECE(^PS(52.41,PSOCPEND,0),"^",12),+$PIECE($GET(^("INI")),"^"),PSOCPEND)
- +29 KILL ^PS(52.41,"ACL",+$PIECE(^PS(52.41,PSOCPEND,0),"^",13),$PIECE(^(0),"^",12),PSOCPEND),^PS(52.41,"AQ",+$PIECE($GET(^PS(52.41,PSOCPEND,0)),"^",21),PSOCPEND)
- +30 SET $PIECE(^PS(52.41,PSOCPEND,4),"^")="External order, unable to successfully transmit to CPRS."
- End DoDot:1
- SET $PIECE(^PS(52.41,PSOCPEND,0),"^",3)="DC"
- SET PSOEXMS="Unable to send CHCS order to CPRS."
- DO NAK^PSOHLEXC
- QUIT
- +31 ;Successful transmission to CPRS
- +32 SET DA=PSOCPEND
- SET DIK="^PS(52.41,"
- DO IX^DIK
- +33 QUIT
- SIGS ;
- +1 NEW PSOHZZZ,PSOHZZZZ
- +2 SET PSOHZZZ=1
- SET PSOHZZZZ=""
- +3 FOR
- SET PSOHZZZZ=$ORDER(^PS(52.41,ORD,"SIG",PSOHZZZZ))
- if PSOHZZZZ=""
- QUIT
- IF $DATA(^(PSOHZZZZ,0))
- SET SIG(PSOHZZZ)=$GET(^(0))
- SET PSOHZZZ=PSOHZZZ+1
- +4 IF $ORDER(PSONEW("SIG",""))'=""
- SET PSOHZZZZ=""
- FOR
- SET PSOHZZZZ=$ORDER(PSONEW("SIG",PSOHZZZZ))
- if PSOHZZZZ=""
- QUIT
- SET SIG(PSOHZZZ)=$GET(PSONEW("SIG",PSOHZZZZ))
- SET PSOHZZZ=PSOHZZZ+1
- +5 IF $ORDER(PSONEW("SIG",""))'=""
- QUIT
- +6 IF $ORDER(PRC(""))'=""
- SET PSOHZZZZ=""
- FOR
- SET PSOHZZZZ=$ORDER(PRC(PSOHZZZZ))
- if PSOHZZZZ=""
- QUIT
- IF $DATA(PRC(PSOHZZZZ))
- SET SIG(PSOHZZZ)=$GET(PRC(PSOHZZZZ))
- SET PSOHZZZ=PSOHZZZ+1
- +7 QUIT