source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPHLQU.m@ 1607

PRCPHLQU ;WISC/CC/DWA-Build/receive HL7 messages for QOH queries ;4/00
V ;;5.1;IFCAP;**1,24,52**;Oct 20, 2000
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 Q
 ;
BLDSEG(INVPT) ;
 ;
 N %,%H,%I,CNT,DATETIME,HLA,HLCS,HLEVN,HLFS,MC,MYRESULT,MYOPTNS,SEG
 S CNT=0
 I $P($G(^PRCP(445,INVPT,5)),"^",1)']"" Q  ; no supply station
 ;
 ; set up environment for message
1 D INIT^HLFNC2("PRCP EV QOH REQ",.HL)
 ; S HLL("LINKS",1)="PRCP EV QOH REQ"_"^"_$P(^PRCP(445.5,$P(^PRCP(445,INVPT,5),"^",1),0),"^",3)
 I $G(HL) D  Q  ; error occurred
 . ; put error handler here for init failure
 . W !,"HL7 can't build your QOH update request now.  Please try later."
 . W !,"HL7 Error: "_$P(HL,"^",2)
 S HLFS=$G(HL("FS")) I HLFS="" S HLFS="|"
 S HLCS=$E(HL("ECH"),1)
 ;
 ; Add message txt to HLA array
 ; create QRD segment
2 D NOW^%DTC S DATETIME=$P(17000000+%,".",1)_$P(%,".",2)
 S SEG="QRD"_HL("FS")_DATETIME_HL("FS")_"R"_HL("FS")_"D"_HL("FS")_"QOH"_HL("FS")_HL("FS")_HL("FS")_HL("FS")_HL("FS")_"STA"_HL("FS")_HL("FS")_HL("FS")_"S"
 S HLA("HLS",1)=SEG
 ;
 ; create QRF segment
 S SEG="QRF"_HL("FS")_HL("FS")_DATETIME_HL("FS")_HL("FS")_HL("FS")_"~"_$P(^PRCP(445,INVPT,0),"^",1)
 S HLA("HLS",2)=SEG
 ;
 S HLL("LINKS",1)="PRCP SU QOH REQ"_"^"_$P(^PRCP(445.5,$P(^PRCP(445,INVPT,5),"^",1),0),"^",3)
 ;
 ;call HL7 to transmit message
3 D GENERATE^HLMA("PRCP EV QOH REQ","LM",1,.MYRESULT,"",.MYOPTNS)
 I $P(MYRESULT,"^",2,3)]"" D
 . ; error handler for message send failures
 . W !,"ERROR: ",MYRESULT
 Q
 ;
GETMSG(PRCPDA,PRCPDONE) ; receive query information from file 447.1
 N ITEMDATA,PRCPDATA,PRCPHL7,PRCPITDA,PRCPITEM,PRCPITNM,PRCPLEFT,PRCPQTY,PRCPREP,PRCPSEC,PRCPSITE,PRCPSSFL,PRCPWHEN
 ;
 S PRCPDATA=^PRCP(447.1,PRCPDA,0)
 S PRCPHL7=$P(PRCPDATA,"^",6)_".447.1"
 S PRCPSITE=$P(PRCPDATA,"^",2)
 S PRCPSEC=$P(PRCPDATA,"^",3)
 S PRCPWHEN=$P(PRCPDATA,"^",4)
 S PRCPREP=0 ; flag to replace current GIP values
 S PRCPSSFL=$P($G(^PRCP(445.5,$P($G(^PRCP(445,PRCPSEC,5)),"^",1),0)),"^",2)
 ;
 L +^PRCP(445,PRCPSEC,7):3 I $T=0 Q
 D ADD^PRCPULOC(445,PRCPSEC_"-7",0,"HL7 Transaction processing")
 S PRCPREP=$G(^PRCP(445,PRCPSEC,7))
 I +PRCPREP=0!($P(PRCPREP,"^",2)]""&($P(PRCPREP,"^",2)'<PRCPWHEN)) D
 . S PRCPREP=0
 . L -^PRCP(445,PRCPSEC,7)
 . D CLEAR^PRCPULOC(445,PRCPSEC_"-7",0)
 I '$D(^PRCP(445,PRCPSEC)) S ERR="3A" G ERR ; secondary not in GIP
 I $P(^PRCP(445,PRCPSEC,0),"^",3)'="S" S ERR="3B" G ERR ; not a secondary
 I $P($G(^PRCP(445,PRCPSEC,5)),"^",1)']"" S ERR="3F" G ERR ; not a supply station secondary
 S PRCPHLPO("DATE")=PRCPWHEN
 S PRCPHLPO("REASON")=""
 S PRCPHLPO("RECIPIENT")=""
 S PRCPHLPO("USER")=""
 I PRCPREP'=0 D
 . N Y
 . S Y=$P(PRCPREP,"^",2) D DD^%DT
 . S PRCPHLPO("REASON")=":Authorized "_Y_" by "_$P(^VA(200,+PRCPREP,0),"^",1)
 . S PRCPHLPO("USER")=$P(PRCPREP,"^",1)
 . S PRCPHLPO("TRAN")=$$ORDERNO^PRCPUTRX(PRCPSEC)
 ;
 S PRCPITDA=0
LOOP S PRCPITDA=$O(^PRCP(447.1,PRCPDA,1,PRCPITDA)) I '+PRCPITDA G Q
 S PRCPDATA=^PRCP(447.1,PRCPDA,1,PRCPITDA,0)
 S PRCPITEM=$P(PRCPDATA,"^",1)
 S PRCPITNM=$P(PRCPDATA,"^",4)
 S PRCPLEFT=$P(PRCPDATA,"^",2)
 I '$D(^PRCP(445,PRCPSEC,1,PRCPITEM,0)) S PRCPQTY(+PRCPITEM)=PRCPLEFT_"^"_PRCPITNM_"^**Not in Inv Pt." G LOOP
 I $P(^PRCP(445,PRCPSEC,1,PRCPITEM,0),"^",9)'>0 S PRCPQTY(+PRCPITEM)=+PRCPLEFT_"^"_PRCPITNM_"^**Not a SS item" G LOOP
 I $P($G(^PRC(441,+PRCPITEM,0)),"^",6)="S" S PRCPQTY(+PRCPITEM)=+PRCPLEFT_"^"_PRCPITNM_"^**CC or IK, not SS item" G LOOP
 ; compare name in 445 with name sent, CONTINUE
 I PRCPSSFL="O",$P(^PRC(441,PRCPITEM,0),"^",2)'=PRCPITNM D NAME^PRCPHL70(PRCPSEC,PRCPITEM,PRCPITNM,PRCPSSFL,PRCPHL7) ; name differs, send message
 I PRCPSSFL="S",$G(^PRCP(445,PRCPSEC,1,PRCPITEM,6))'=PRCPITNM D NAME^PRCPHL70(PRCPSEC,PRCPITEM,PRCPITNM,PRCPSSFL,PRCPHL7) ; name differs, send message
 S PRCPDATA=$G(^PRCP(445,PRCPSEC,1,PRCPITEM,9))
 I $P(PRCPDATA,"^",2)'>PRCPWHEN D
 . S $P(PRCPDATA,"^",2)=PRCPWHEN
 . S $P(PRCPDATA,"^",1)=PRCPLEFT
 . S ^PRCP(445,PRCPSEC,1,PRCPITEM,9)=PRCPDATA
 S PRCPHLPO("ITEM")=^PRCP(445,PRCPSEC,1,PRCPITEM,0)
 I PRCPREP'=0 D
 . S PRCPHLPO("QTY")=PRCPLEFT-$P(PRCPHLPO("ITEM"),"^",7)
 . S PRCPHLPO("INVVAL")=$J(PRCPHLPO("QTY")*$P(PRCPHLPO("ITEM"),"^",22),0,2)
 . S PRCPHLPO("SELVAL")=PRCPHLPO("INVVAL")
 . D UPDATE^PRCPHL1(PRCPSEC,PRCPITEM,PRCPLEFT,.PRCPHLPO,"Q")
 I PRCPREP=0,$P(PRCPHLPO("ITEM"),"^",7)'=PRCPLEFT S PRCPQTY(PRCPITEM)=PRCPLEFT_"^"_$P(PRCPHLPO("ITEM"),"^",7)
 G LOOP
 ;
Q N ITEM,ITEMNAME,LN,PRCPXMY,QTYSS,QTYIP,SSTYPE,XMB,XMDUZ,XMTEXT
 S SSTYPE=$P(^PRCP(445.5,$P(^PRCP(445,PRCPSEC,5),"^",1),0),"^",2)
 K ^TMP($J,"PRCPHL7")
 S ITEM=0,LN=1
 F  S ITEM=$O(PRCPQTY(ITEM)) Q:'ITEM  D
 . S ITEMNAME=$P($G(^PRCP(445,PRCPSEC,1,ITEM,6)),"^",1)
 . I SSTYPE="O" S ITEMNAME=$P(^PRC(441,ITEM,0),"^",2)
 . S QTYSS=+PRCPQTY(ITEM),QTYIP=+$P(PRCPQTY(ITEM),"^",2)
 . S ^TMP($J,"PRCPHL7",1,LN,0)=$E("       ",$L(QTYIP)+1,7)_QTYIP_" "_$E("       ",$L(QTYSS)+1,7)_QTYSS_" "_$E("       ",$L(ITEM)+1,7)_ITEM_" "_$E(ITEMNAME,1,30)_" "_$P(PRCPQTY(ITEM),"^",3)
 . S LN=LN+1
 I PRCPREP=0,'$O(PRCPQTY(0)) S ^TMP($J,"PRCPHL7",1,1,0)="<no discrepancies found>"
 I PRCPREP'=0 S ^TMP($J,"PRCPHL7",1,1,0)="<The GIP on-hand quantity has been adjusted to supply station totals>"
 S ^TMP($J,"PRCPHL7",1)=LN
 D GETUSER^PRCPXTRM(PRCPSEC) Q:'$O(PRCPXMY(""))  ; send message to secondary inventory point managers
 F  S ITEM=$O(PRCPXMY(ITEM)) Q:ITEM'>0  I PRCPXMY(ITEM)=1 S XMY(ITEM)=""
 S XMTEXT="^TMP($J,""PRCPHL7"",1,"
 S XMB(1)=$$INVNAME^PRCPUX1(PRCPSEC)
 S XMB="PRCP_ALL_ITEMS_QTY_UPDATE"
 S XMDUZ="SUPPLY STATION INTERFACE"
 D EN^XMB
 K ^TMP($J,"PRCPHL7")
 ;
 S $P(^PRCP(445,PRCPSEC,6),"^",1)=PRCPWHEN
 I PRCPREP'=0 D
 . N DIE,DA,DR
 . L -^PRCP(445,PRCPSEC,7) D CLEAR^PRCPULOC(445,PRCPSEC_"-7",0)
 . S DIE="^PRCP(445,",DA=PRCPSEC,DR="24////@;25////@" D ^DIE
 S PRCPDONE=1
 Q
 ;
ERR ;
 N NUMBER,PRCPXMY
 S NUMBER=ERR
 S PRCPHLPO("SIPNAME")="" I $D(PRCPSEC) S PRCPHLPO("SIPNAME")=$$INVNAME^PRCPUX1(PRCPSEC)
 S PRCPHLPO("ITEM")="" I $D(PRCPITEM) S PRCPHLPO("ITEM")=PRCPITEM
 S PRCPHLPO("NAME")="" I $D(PRCPITEM) S PRCPHLPO("NAME")=PRCPITNM
 S PRCPHLPO("LEFT")="" I $D(PRCPLEFT) S PRCPHLPO("LEFT")=PRCPLEFT
 D ERR^PRCPHLM0(NUMBER,"PRCP_BAD_QUERY",PRCPSEC,.PRCPHLPO,PRCPHL7,"")
 S PRCPDONE=1
 Q