- PRCPHLU ;WISC/CC - PROCESS HL7 TXN ON ITEM UTILIZATION AT THE SUPPLY STATION; 4/00
- V ;;5.1;IFCAP;**1**;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- N DA,DIC,DIE,DLAYGO,DR,ERR,I,J,NUMBER,X,Y
- N PRCPAMT,PRCPHL,PRCPHL7,PRCPITEM,PRCPITNM,PRCPLEFT,PRCPOC,PRCPRCOD,PRCPREAS
- N PRCPREC,PRCPSEC,PRCPSECN,PRCPSITE,PRCPTIME,PRCPTXN,PRCPUSER,PRCP7
- S I=1
- ;
- RAS I HL("MTN")'="RAS" S ERR="1B" G ERR ; wrong message name
- X HLNEXT I HLQUIT'>0 S ERR="1A" G ERR ; missing segments
- S PRCPHL(1)=HLNODE,I=I+1,J=0
- ;
- X HLNEXT I HLQUIT'>0 S ERR="1A" G ERR ; missing segments
- S PRCPHL(I)=HLNODE,J=0,I=I+1
- S PRCPREC=""
- I $$FLD^HLCSUTL(HLNODE,1)="PID" D I HLQUIT'>0 S ERR="1A" G ERR ; missing segments
- . S PRCPREC=$$FLD^HLCSUTL(HLNODE,6)
- . S PRCPREC=$$FMNAME^HLFNC(PRCPREC,$E(HL("ECH"),1))
- . X HLNEXT
- . S PRCPHL(I)=HLNODE,J=0,I=I+1
- ;
- I $$FLD^HLCSUTL(HLNODE,1)'="ORC" S ERR="1A" G ERR ; wrong segment name
- D ORC I $D(ERR) G ERR
- ;
- X HLNEXT I HLQUIT'>0 S ERR="1A" G ERR ; missing segments
- S PRCPHL(I)=HLNODE,J=0,I=I+1
- I $$FLD^HLCSUTL(HLNODE,1)'="RXA" S ERR="1A" G ERR ; wrong segment name
- ;
- ; RXA SEGMENT
- RXA S PRCPITEM=$$FLD^HLCSUTL(HLNODE,6) ; ID~NAME
- S PRCPTIME=$$FLD^HLCSUTL(HLNODE,4)
- S PRCPTIME=$$FMDATE^HLFNC(PRCPTIME)
- S PRCPAMT=$$FLD^HLCSUTL(HLNODE,7) ; QTY - 2ndary issue units
- S PRCPUSER=$$FLD^HLCSUTL(HLNODE,11)
- S PRCPUSER=$P(PRCPUSER,$E(HL("ECH"),1),2)
- S PRCPUSER=$$FMNAME^HLFNC(PRCPUSER,$E(HL("ECH"),1))
- S PRCPREAS=$$FLD^HLCSUTL(HLNODE,19)
- S PRCPRCOD=$P(PRCPREAS,$E(HL("ECH"),1),1)
- S PRCPREAS=PRCPRCOD_"~"_$P(PRCPREAS,$E(HL("ECH"),1),2)
- S PRCPLEFT=$$FLD^HLCSUTL(HLNODE,20)
- ;
- ; verify info extracted
- I +PRCPITEM'=$P(PRCPITEM,$E(HL("ECH"),1),1)!(+PRCPITEM=0) S ERR="6E" G ERR ; item number invalid
- I '$D(^PRCP(445,PRCPSECN,1,$P(PRCPITEM,$E(HL("ECH"),1),1))) S ERR="6C" G ERR
- I $P(^PRCP(445,PRCPSECN,1,$P(PRCPITEM,$E(HL("ECH"),1),1),0),"^",9)'>0 S ERR="6D" G ERR ; is item a supply station item?
- ;
- I +PRCPAMT'=PRCPAMT!(PRCPAMT>999999)!(PRCPAMT<-999999) S ERR=4 G ERR
- I +PRCPLEFT'=PRCPLEFT!(PRCPLEFT>999999)!(PRCPLEFT<-999999) S ERR=5 G ERR
- ;
- I PRCPOC="LI",PRCPRCOD'="RTRN",PRCPRCOD'="USGE" S ERR="1D" G ERR
- I PRCPOC="RP",PRCPRCOD]"",PRCPRCOD'="DISP",$E(PRCPRCOD,1,3)'="ADJ" S ERR="1D" G ERR
- ;
- X HLNEXT I HLQUIT'>0 S ERR="1A" G ERR ; missing segments
- S PRCPHL(I)=HLNODE,J=0,I=I+1
- I $$FLD^HLCSUTL(HLNODE,1)'="RXR" S ERR="1A" G ERR ; wrong segment name
- X HLNEXT I HLQUIT'>0 G PROCESS
- S PRCPHL(I)=HLNODE,I=I+1,J=0
- S ERR="1A" G ERR ; too many segments
- G Q
- ;
- ;
- ; ORC SEGMENT
- ORC S PRCPOC=$$FLD^HLCSUTL(HLNODE,2)
- S PRCPSEC=$$FLD^HLCSUTL(HLNODE,5)
- ;
- I HL("MTN")="RAS",PRCPOC'="LI",PRCPOC'="RP" S ERR="1C" Q ; order control wrong
- ; get site and IP info
- I PRCPSEC']"" S ERR="3E" Q
- S PRCPSEC=$P(PRCPSEC,$E(HL("ECH"),1),2) I PRCPSEC']"" S ERR="3E" Q
- S PRCPSITE=$P(PRCPSEC,"-",1)
- I PRCPSITE']"" S ERR="3E" Q
- I '$D(^PRC(411,PRCPSITE,0)) S ERR="3D" Q ; wrong site
- S DIC="^PRCP(445,",DIC(0)="X",X=PRCPSEC,PRCPPRIV=1
- D ^DIC K DIC
- I Y=-1 S ERR="3A" Q ; secondary not in GIP
- S PRCPSECN=$P(Y,"^",1)
- I $P(^PRCP(445,PRCPSECN,0),"^",3)'="S" S ERR="3B" G ERR ; not a secondary
- S PRCPTIME=$$FLD^HLCSUTL(HLNODE,10)
- S PRCPTIME=$$FMDATE^HLFNC(PRCPTIME)
- S PRCPUSER=$$FLD^HLCSUTL(HLNODE,11)
- S PRCPUSER=$P(PRCPUSER,$E(HL("ECH"),1),2)
- S PRCPUSER=$$FMNAME^HLFNC(PRCPUSER,$E(HL("ECH"),1))
- Q
- ERR ;
- S NUMBER=ERR
- I '$D(PRCPSECN) S PRCPSECN=0
- S PRCP7("SIPNAME")="AN UNKNOWN INVENTORY POINT"
- I $D(PRCPSEC),PRCPSEC]"" S PRCP7("SIPNAME")=PRCPSEC
- S PRCP7("ITEM")=""
- I $D(PRCPITEM) S PRCP7("ITEM")=$P(PRCPITEM,$E(HL("ECH"),1),1)
- S PRCP7("NAME")=""
- I $D(PRCPITEM) S PRCP7("NAME")=$P(PRCPITEM,$E(HL("ECH"),1),2)
- S PRCP7("ACTIVITY")=""
- I $D(PRCPREAS) S PRCP7("ACTIVITY")=$E(PRCPREAS,1,4)
- S PRCP7("QTY")="" I $D(PRCPAMT) S PRCP7("QTY")=PRCPAMT
- S PRCP7("LEFT")="" I $D(PRCPLEFT) S PRCP7("LEFT")=PRCPLEFT
- S PRCP7("RECIPIENT")=""
- I $D(PRCPREC) S PRCP7("RECIPIENT")=PRCPREC
- S PRCP7("USER")=""
- I $D(PRCPUSER) S PRCP7("USER")=PRCPUSER
- D ERR^PRCPHLM0(ERR,"PRCP_BAD_ACTIVITY",PRCPSECN,.PRCP7,HLMTIENS_"."_HLMTIEN,.PRCPHL)
- I ERR,$D(PRCPTXN) S DA=PRCPTXN,DIK="^PRCP(447.1," D ^DIK
- G UNLOCK
- ;
- PROCESS N %,%H,%I,PRCPTXNT,PRCPMGTP,CNT,DA,DIC,DIE,DR,N,T,X,Y
- S X="PRCPHL7TXN",CNT=0
- PROCES0 I $D(^PRCS(410.1,"B",X)) D I $D(ERR) S CNT=CNT+1 G PROCES0:CNT<10 S CNT=0 G ERR
- . S N="",N=$O(^PRCS(410.1,"B",X,N)),DA=N
- . L +^PRCS(410.1,DA):15 I $T=0 S ERR=198 Q
- . S T=$P(^PRCS(410.1,N,0),"^",2)+1 S:T<1 T=1
- . S $P(^PRCS(410.1,DA,0),"^",2)=+T
- . S $P(^PRCS(410.1,DA,0),"^",3)=DT
- . L -^PRCS(410.1,DA)
- I '$D(^PRCS(410.1,"B",X)) D I $D(ERR) S CNT=CNT+1 G PROCES0:CNT<10 S CNT=0 G ERR
- . S T=1,DLAYGO=410.1,DIC="^PRCS(410.1,",DIC(0)="FLXZ"
- . D ^DIC K DLAYGO I Y<0 S ERR=199
- . S DA=+Y
- . L +^PRCS(410.1,DA):15 I $T=0 S ERR=198 Q
- . S $P(^PRCS(410.1,DA,0),"^",2)=+T
- . S $P(^PRCS(410.1,DA,0),"^",3)=DT
- . L -^PRCS(410.1,DA)
- ;
- S X=T
- S DIC="^PRCP(447.1,"
- S DIC(0)="L"
- S DLAYGO=447.1
- D ^DIC K DIC
- I Y=-1 S ERR=100 G ERR
- I $P(Y,"^",3)'=1 S ERR=101 G ERR
- S (DA,PRCPTXN)=Y+0
- L +^PRCP(447.1,DA):3 I $T=0 S ERR=102 G ERR
- S DIE="^PRCP(447.1,"
- S DA=PRCPTXN
- D NOW^%DTC
- S PRCPTXNT=%
- S PRCPMGTP=HL("MTN")_HL("ETN")
- S PRCPHL7=HLMTIENS_"."_HLMTIEN
- S DR="1///^S X=PRCPSITE;2///^S X=PRCPSECN;3///^S X=PRCPTXNT;4///^S X=PRCPMGTP;5///^S X=PRCPHL7;8///^S X=PRCPTIME;9///^S X=PRCPREC;10///^S X=PRCPUSER;11///^S X=PRCPREAS"
- D ^DIE
- K DIE,DR
- S DIC="^PRCP(447.1,"_PRCPTXN_",1,"
- S DA(1)=PRCPTXN
- S DIC(0)="L"
- S DLAYGO=447.1
- S DIC("P")=$P(^DD(447.1,7,0),"^",2)
- S X=$P(PRCPITEM,$E(HL("ECH"),1),1)
- S PRCPSET="I 1" ; over rides screen to omit finding case carts/IK's
- D ^DIC K DIC,DA,DLAYGO
- I Y=-1 S ERR=110 G ERR
- I $P(Y,"^",3)'=1 S ERR=111 G ERR
- S DIE="^PRCP(447.1,"_PRCPTXN_",1,"
- S DA=+Y
- S PRCPITNM=$P(PRCPITEM,$E(HL("ECH"),1),2)
- S DR="1///^S X=PRCPLEFT;2///^S X=PRCPAMT;3///^S X=PRCPITNM"
- D ^DIE K DIE,DIC,DR
- UNLOCK I $D(PRCPTXN),PRCPTXN>0 L -^PRCP(447.1,PRCPTXN)
- Q Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPHLU 6083 printed Feb 18, 2025@23:40:22 Page 2
- PRCPHLU ;WISC/CC - PROCESS HL7 TXN ON ITEM UTILIZATION AT THE SUPPLY STATION; 4/00
- V ;;5.1;IFCAP;**1**;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 ;
- +3 NEW DA,DIC,DIE,DLAYGO,DR,ERR,I,J,NUMBER,X,Y
- +4 NEW PRCPAMT,PRCPHL,PRCPHL7,PRCPITEM,PRCPITNM,PRCPLEFT,PRCPOC,PRCPRCOD,PRCPREAS
- +5 NEW PRCPREC,PRCPSEC,PRCPSECN,PRCPSITE,PRCPTIME,PRCPTXN,PRCPUSER,PRCP7
- +6 SET I=1
- +7 ;
- RAS ; wrong message name
- IF HL("MTN")'="RAS"
- SET ERR="1B"
- GOTO ERR
- +1 ; missing segments
- XECUTE HLNEXT
- IF HLQUIT'>0
- SET ERR="1A"
- GOTO ERR
- +2 SET PRCPHL(1)=HLNODE
- SET I=I+1
- SET J=0
- +3 ;
- +4 ; missing segments
- XECUTE HLNEXT
- IF HLQUIT'>0
- SET ERR="1A"
- GOTO ERR
- +5 SET PRCPHL(I)=HLNODE
- SET J=0
- SET I=I+1
- +6 SET PRCPREC=""
- +7 ; missing segments
- IF $$FLD^HLCSUTL(HLNODE,1)="PID"
- Begin DoDot:1
- +8 SET PRCPREC=$$FLD^HLCSUTL(HLNODE,6)
- +9 SET PRCPREC=$$FMNAME^HLFNC(PRCPREC,$EXTRACT(HL("ECH"),1))
- +10 XECUTE HLNEXT
- +11 SET PRCPHL(I)=HLNODE
- SET J=0
- SET I=I+1
- End DoDot:1
- IF HLQUIT'>0
- SET ERR="1A"
- GOTO ERR
- +12 ;
- +13 ; wrong segment name
- IF $$FLD^HLCSUTL(HLNODE,1)'="ORC"
- SET ERR="1A"
- GOTO ERR
- +14 DO ORC
- IF $DATA(ERR)
- GOTO ERR
- +15 ;
- +16 ; missing segments
- XECUTE HLNEXT
- IF HLQUIT'>0
- SET ERR="1A"
- GOTO ERR
- +17 SET PRCPHL(I)=HLNODE
- SET J=0
- SET I=I+1
- +18 ; wrong segment name
- IF $$FLD^HLCSUTL(HLNODE,1)'="RXA"
- SET ERR="1A"
- GOTO ERR
- +19 ;
- +20 ; RXA SEGMENT
- RXA ; ID~NAME
- SET PRCPITEM=$$FLD^HLCSUTL(HLNODE,6)
- +1 SET PRCPTIME=$$FLD^HLCSUTL(HLNODE,4)
- +2 SET PRCPTIME=$$FMDATE^HLFNC(PRCPTIME)
- +3 ; QTY - 2ndary issue units
- SET PRCPAMT=$$FLD^HLCSUTL(HLNODE,7)
- +4 SET PRCPUSER=$$FLD^HLCSUTL(HLNODE,11)
- +5 SET PRCPUSER=$PIECE(PRCPUSER,$EXTRACT(HL("ECH"),1),2)
- +6 SET PRCPUSER=$$FMNAME^HLFNC(PRCPUSER,$EXTRACT(HL("ECH"),1))
- +7 SET PRCPREAS=$$FLD^HLCSUTL(HLNODE,19)
- +8 SET PRCPRCOD=$PIECE(PRCPREAS,$EXTRACT(HL("ECH"),1),1)
- +9 SET PRCPREAS=PRCPRCOD_"~"_$PIECE(PRCPREAS,$EXTRACT(HL("ECH"),1),2)
- +10 SET PRCPLEFT=$$FLD^HLCSUTL(HLNODE,20)
- +11 ;
- +12 ; verify info extracted
- +13 ; item number invalid
- IF +PRCPITEM'=$PIECE(PRCPITEM,$EXTRACT(HL("ECH"),1),1)!(+PRCPITEM=0)
- SET ERR="6E"
- GOTO ERR
- +14 IF '$DATA(^PRCP(445,PRCPSECN,1,$PIECE(PRCPITEM,$EXTRACT(HL("ECH"),1),1)))
- SET ERR="6C"
- GOTO ERR
- +15 ; is item a supply station item?
- IF $PIECE(^PRCP(445,PRCPSECN,1,$PIECE(PRCPITEM,$EXTRACT(HL("ECH"),1),1),0),"^",9)'>0
- SET ERR="6D"
- GOTO ERR
- +16 ;
- +17 IF +PRCPAMT'=PRCPAMT!(PRCPAMT>999999)!(PRCPAMT<-999999)
- SET ERR=4
- GOTO ERR
- +18 IF +PRCPLEFT'=PRCPLEFT!(PRCPLEFT>999999)!(PRCPLEFT<-999999)
- SET ERR=5
- GOTO ERR
- +19 ;
- +20 IF PRCPOC="LI"
- IF PRCPRCOD'="RTRN"
- IF PRCPRCOD'="USGE"
- SET ERR="1D"
- GOTO ERR
- +21 IF PRCPOC="RP"
- IF PRCPRCOD]""
- IF PRCPRCOD'="DISP"
- IF $EXTRACT(PRCPRCOD,1,3)'="ADJ"
- SET ERR="1D"
- GOTO ERR
- +22 ;
- +23 ; missing segments
- XECUTE HLNEXT
- IF HLQUIT'>0
- SET ERR="1A"
- GOTO ERR
- +24 SET PRCPHL(I)=HLNODE
- SET J=0
- SET I=I+1
- +25 ; wrong segment name
- IF $$FLD^HLCSUTL(HLNODE,1)'="RXR"
- SET ERR="1A"
- GOTO ERR
- +26 XECUTE HLNEXT
- IF HLQUIT'>0
- GOTO PROCESS
- +27 SET PRCPHL(I)=HLNODE
- SET I=I+1
- SET J=0
- +28 ; too many segments
- SET ERR="1A"
- GOTO ERR
- +29 GOTO Q
- +30 ;
- +31 ;
- +32 ; ORC SEGMENT
- ORC SET PRCPOC=$$FLD^HLCSUTL(HLNODE,2)
- +1 SET PRCPSEC=$$FLD^HLCSUTL(HLNODE,5)
- +2 ;
- +3 ; order control wrong
- IF HL("MTN")="RAS"
- IF PRCPOC'="LI"
- IF PRCPOC'="RP"
- SET ERR="1C"
- QUIT
- +4 ; get site and IP info
- +5 IF PRCPSEC']""
- SET ERR="3E"
- QUIT
- +6 SET PRCPSEC=$PIECE(PRCPSEC,$EXTRACT(HL("ECH"),1),2)
- IF PRCPSEC']""
- SET ERR="3E"
- QUIT
- +7 SET PRCPSITE=$PIECE(PRCPSEC,"-",1)
- +8 IF PRCPSITE']""
- SET ERR="3E"
- QUIT
- +9 ; wrong site
- IF '$DATA(^PRC(411,PRCPSITE,0))
- SET ERR="3D"
- QUIT
- +10 SET DIC="^PRCP(445,"
- SET DIC(0)="X"
- SET X=PRCPSEC
- SET PRCPPRIV=1
- +11 DO ^DIC
- KILL DIC
- +12 ; secondary not in GIP
- IF Y=-1
- SET ERR="3A"
- QUIT
- +13 SET PRCPSECN=$PIECE(Y,"^",1)
- +14 ; not a secondary
- IF $PIECE(^PRCP(445,PRCPSECN,0),"^",3)'="S"
- SET ERR="3B"
- GOTO ERR
- +15 SET PRCPTIME=$$FLD^HLCSUTL(HLNODE,10)
- +16 SET PRCPTIME=$$FMDATE^HLFNC(PRCPTIME)
- +17 SET PRCPUSER=$$FLD^HLCSUTL(HLNODE,11)
- +18 SET PRCPUSER=$PIECE(PRCPUSER,$EXTRACT(HL("ECH"),1),2)
- +19 SET PRCPUSER=$$FMNAME^HLFNC(PRCPUSER,$EXTRACT(HL("ECH"),1))
- +20 QUIT
- ERR ;
- +1 SET NUMBER=ERR
- +2 IF '$DATA(PRCPSECN)
- SET PRCPSECN=0
- +3 SET PRCP7("SIPNAME")="AN UNKNOWN INVENTORY POINT"
- +4 IF $DATA(PRCPSEC)
- IF PRCPSEC]""
- SET PRCP7("SIPNAME")=PRCPSEC
- +5 SET PRCP7("ITEM")=""
- +6 IF $DATA(PRCPITEM)
- SET PRCP7("ITEM")=$PIECE(PRCPITEM,$EXTRACT(HL("ECH"),1),1)
- +7 SET PRCP7("NAME")=""
- +8 IF $DATA(PRCPITEM)
- SET PRCP7("NAME")=$PIECE(PRCPITEM,$EXTRACT(HL("ECH"),1),2)
- +9 SET PRCP7("ACTIVITY")=""
- +10 IF $DATA(PRCPREAS)
- SET PRCP7("ACTIVITY")=$EXTRACT(PRCPREAS,1,4)
- +11 SET PRCP7("QTY")=""
- IF $DATA(PRCPAMT)
- SET PRCP7("QTY")=PRCPAMT
- +12 SET PRCP7("LEFT")=""
- IF $DATA(PRCPLEFT)
- SET PRCP7("LEFT")=PRCPLEFT
- +13 SET PRCP7("RECIPIENT")=""
- +14 IF $DATA(PRCPREC)
- SET PRCP7("RECIPIENT")=PRCPREC
- +15 SET PRCP7("USER")=""
- +16 IF $DATA(PRCPUSER)
- SET PRCP7("USER")=PRCPUSER
- +17 DO ERR^PRCPHLM0(ERR,"PRCP_BAD_ACTIVITY",PRCPSECN,.PRCP7,HLMTIENS_"."_HLMTIEN,.PRCPHL)
- +18 IF ERR
- IF $DATA(PRCPTXN)
- SET DA=PRCPTXN
- SET DIK="^PRCP(447.1,"
- DO ^DIK
- +19 GOTO UNLOCK
- +20 ;
- PROCESS NEW %,%H,%I,PRCPTXNT,PRCPMGTP,CNT,DA,DIC,DIE,DR,N,T,X,Y
- +1 SET X="PRCPHL7TXN"
- SET CNT=0
- PROCES0 IF $DATA(^PRCS(410.1,"B",X))
- Begin DoDot:1
- +1 SET N=""
- SET N=$ORDER(^PRCS(410.1,"B",X,N))
- SET DA=N
- +2 LOCK +^PRCS(410.1,DA):15
- IF $TEST=0
- SET ERR=198
- QUIT
- +3 SET T=$PIECE(^PRCS(410.1,N,0),"^",2)+1
- if T<1
- SET T=1
- +4 SET $PIECE(^PRCS(410.1,DA,0),"^",2)=+T
- +5 SET $PIECE(^PRCS(410.1,DA,0),"^",3)=DT
- +6 LOCK -^PRCS(410.1,DA)
- End DoDot:1
- IF $DATA(ERR)
- SET CNT=CNT+1
- if CNT<10
- GOTO PROCES0
- SET CNT=0
- GOTO ERR
- +7 IF '$DATA(^PRCS(410.1,"B",X))
- Begin DoDot:1
- +8 SET T=1
- SET DLAYGO=410.1
- SET DIC="^PRCS(410.1,"
- SET DIC(0)="FLXZ"
- +9 DO ^DIC
- KILL DLAYGO
- IF Y<0
- SET ERR=199
- +10 SET DA=+Y
- +11 LOCK +^PRCS(410.1,DA):15
- IF $TEST=0
- SET ERR=198
- QUIT
- +12 SET $PIECE(^PRCS(410.1,DA,0),"^",2)=+T
- +13 SET $PIECE(^PRCS(410.1,DA,0),"^",3)=DT
- +14 LOCK -^PRCS(410.1,DA)
- End DoDot:1
- IF $DATA(ERR)
- SET CNT=CNT+1
- if CNT<10
- GOTO PROCES0
- SET CNT=0
- GOTO ERR
- +15 ;
- +16 SET X=T
- +17 SET DIC="^PRCP(447.1,"
- +18 SET DIC(0)="L"
- +19 SET DLAYGO=447.1
- +20 DO ^DIC
- KILL DIC
- +21 IF Y=-1
- SET ERR=100
- GOTO ERR
- +22 IF $PIECE(Y,"^",3)'=1
- SET ERR=101
- GOTO ERR
- +23 SET (DA,PRCPTXN)=Y+0
- +24 LOCK +^PRCP(447.1,DA):3
- IF $TEST=0
- SET ERR=102
- GOTO ERR
- +25 SET DIE="^PRCP(447.1,"
- +26 SET DA=PRCPTXN
- +27 DO NOW^%DTC
- +28 SET PRCPTXNT=%
- +29 SET PRCPMGTP=HL("MTN")_HL("ETN")
- +30 SET PRCPHL7=HLMTIENS_"."_HLMTIEN
- +31 SET DR="1///^S X=PRCPSITE;2///^S X=PRCPSECN;3///^S X=PRCPTXNT;4///^S X=PRCPMGTP;5///^S X=PRCPHL7;8///^S X=PRCPTIME;9///^S X=PRCPREC;10///^S X=PRCPUSER;11///^S X=PRCPREAS"
- +32 DO ^DIE
- +33 KILL DIE,DR
- +34 SET DIC="^PRCP(447.1,"_PRCPTXN_",1,"
- +35 SET DA(1)=PRCPTXN
- +36 SET DIC(0)="L"
- +37 SET DLAYGO=447.1
- +38 SET DIC("P")=$PIECE(^DD(447.1,7,0),"^",2)
- +39 SET X=$PIECE(PRCPITEM,$EXTRACT(HL("ECH"),1),1)
- +40 ; over rides screen to omit finding case carts/IK's
- SET PRCPSET="I 1"
- +41 DO ^DIC
- KILL DIC,DA,DLAYGO
- +42 IF Y=-1
- SET ERR=110
- GOTO ERR
- +43 IF $PIECE(Y,"^",3)'=1
- SET ERR=111
- GOTO ERR
- +44 SET DIE="^PRCP(447.1,"_PRCPTXN_",1,"
- +45 SET DA=+Y
- +46 SET PRCPITNM=$PIECE(PRCPITEM,$EXTRACT(HL("ECH"),1),2)
- +47 SET DR="1///^S X=PRCPLEFT;2///^S X=PRCPAMT;3///^S X=PRCPITNM"
- +48 DO ^DIE
- KILL DIE,DIC,DR
- UNLOCK IF $DATA(PRCPTXN)
- IF PRCPTXN>0
- LOCK -^PRCP(447.1,PRCPTXN)
- Q QUIT