- PSABRKU9 ;VMP/PW-ORDER UNIT AUTO UPDATE FOR MCKESSON ;9/19/2004
- ;;3.0;DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**48**;10/24/97
- ;routine to be identical to PSAUP8
- ;References to ^PSDRUG( are covered by IA #2095
- Q
- OUAUTO ;EP for Order Unit Auto Update from PSABRKU6
- ; needs PSACTRL PSALINE from PSABRKU6
- ; PSAI - invoice PSAD - drug
- EN N DRDA,DROUDA,DROUNM,DRDUOU,INVOUNM,INVOUDA,INVDUOU,XX
- N PSADATA,VSNDUOU,VSNDRDA,VSDSYNDA,VSNDRD0,VSNSYND0,VCNT
- N INVOUNM,SYNDA,IVSN,IVSN0,SYN0,SYNDUOU,SYNIEN,VSNIEN,VSNSYNDA
- S PSADATA=^XTMP("PSAPV",PSACTRL,"IT",PSALINE)
- S PSADATA=$$PSADATA()
- S ^XTMP("PSAPV",PSACTRL,"IT",PSALINE)=PSADATA ;adj invoice OU, DUOU w postmaster
- Q
- PSADATA() ;extrensic return PSADATA modified
- S XX=PSADATA,(VSNDUOU,SYNDUOU,DRDUOU)=""
- S INVOUNM=$P(XX,U,2) S:INVOUNM["~" INVOUNM=$P(INVOUNM,"~")
- S DRDA=$P(XX,U,6),SYNDA=$P(XX,U,7),IVSN0=$P(XX,U,5)
- S DRDUOU=$$GET1^DIQ(50,DRDA,15)
- VSN ;set VSNDUOU= PSDRUG( unique VSN value or XTMP( value
- S IVSN=$S(IVSN0["~":$P(IVSN0,"~"),1:IVSN0)
- S (VSNDRDA,VCNT)=0 F S VSNDRDA=$O(^PSDRUG("AVSN",IVSN,VSNDRDA)) Q:VSNDRDA'>0 D
- .S VSNSYNDA=0 F S VSNSYNDA=$O(^PSDRUG("AVSN",IVSN,VSNDRDA,VSNSYNDA)) Q:VSNSYNDA'>0 S VCNT=VCNT+1 S VSNDRD0=VSNDRDA,VSNSYND0=VSNSYNDA
- I ((IVSN0["~")!(VCNT'=1)) I $D(^XTMP("PSAVSN",IVSN)) S VSNDUOU=^(IVSN) I 1
- E D
- .I VCNT'=1 Q
- .; FYI both SYN and VSN values should be comming from the same Synonym
- .S VSNIEN=VSNSYND0_","_VSNDRD0
- .S VSNDUOU=$$GET1^DIQ(50.1,VSNIEN,403)
- I VSNDUOU="",$D(^XTMP("PSAVSN",IVSN)) S VSNDUOU=^(IVSN)
- ;
- SYNDUOU ;set SYNDUOU= to PSDRUG( or XTMP value
- S SYNIEN=SYNDA_","_DRDA
- S SYNDUOU=$$GET1^DIQ(50.1,SYNIEN,403)
- I '$L(SYNDUOU),$D(^XTMP("PSAVSN",IVSN)) S SYNDUOU=^(IVSN) D
- . I SYNDUOU'=DRDUOU Q
- . L +^PSDRUG(DRDA,1,SYNDA,0):10 Q:'$T
- . S SYN0=^PSDRUG(DRDA,1,SYNDA,0)
- . S $P(SYN0,U,7)=SYNDUOU,^PSDRUG(DRDA,1,SYNDA,0)=SYN0
- . L -^PSDRUG(DRDA,1,SYNDA,0)
- ;
- TESTDUOU ; test if DUOUs are =
- I VSNDUOU=SYNDUOU,SYNDUOU=DRDUOU I 1
- E D G Q ; DUOUs '= but maybe VSN & SYN agree, set into IT
- . I '$L(VSNDUOU) Q
- . I VSNDUOU=SYNDUOU S $P(XX,U,20)=VSNDUOU,PSADATA=XX
- SETDUOU S $P(XX,U,20)=DRDUOU,PSADATA=XX ;set DUOU into PSAPV "IT"
- ;test for OU change
- CHKOU S DROUNM=$$GET1^DIQ(50,DRDA,12)
- S DROUDA=$$GET1^DIQ(50,DRDA,12,"I")
- I $E(INVOUNM,1,2)'="EA" G Q
- S $P(XX,U,12)=DROUDA,$P(XX,U,13)=.5,$P(XX,U,14)=DT
- S PSADATA=XX
- Q ;W ! ZW VSNDUOU,SYNDUOU,DRDUOU,PSADATA W !
- Q PSADATA
- PSABRKU9 ;VMP/PW-ORDER UNIT AUTO UPDATE FOR MCKESSON ;9/19/2004
- +1 ;;3.0;DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**48**;10/24/97
- +2 ;routine to be identical to PSAUP8
- +3 ;References to ^PSDRUG( are covered by IA #2095
- +4 QUIT
- OUAUTO ;EP for Order Unit Auto Update from PSABRKU6
- +1 ; needs PSACTRL PSALINE from PSABRKU6
- +2 ; PSAI - invoice PSAD - drug
- EN NEW DRDA,DROUDA,DROUNM,DRDUOU,INVOUNM,INVOUDA,INVDUOU,XX
- +1 NEW PSADATA,VSNDUOU,VSNDRDA,VSDSYNDA,VSNDRD0,VSNSYND0,VCNT
- +2 NEW INVOUNM,SYNDA,IVSN,IVSN0,SYN0,SYNDUOU,SYNIEN,VSNIEN,VSNSYNDA
- +3 SET PSADATA=^XTMP("PSAPV",PSACTRL,"IT",PSALINE)
- +4 SET PSADATA=$$PSADATA()
- +5 ;adj invoice OU, DUOU w postmaster
- SET ^XTMP("PSAPV",PSACTRL,"IT",PSALINE)=PSADATA
- +6 QUIT
- PSADATA() ;extrensic return PSADATA modified
- +1 SET XX=PSADATA
- SET (VSNDUOU,SYNDUOU,DRDUOU)=""
- +2 SET INVOUNM=$PIECE(XX,U,2)
- IF INVOUNM["~"
- SET INVOUNM=$PIECE(INVOUNM,"~")
- +3 SET DRDA=$PIECE(XX,U,6)
- SET SYNDA=$PIECE(XX,U,7)
- SET IVSN0=$PIECE(XX,U,5)
- +4 SET DRDUOU=$$GET1^DIQ(50,DRDA,15)
- VSN ;set VSNDUOU= PSDRUG( unique VSN value or XTMP( value
- +1 SET IVSN=$SELECT(IVSN0["~":$PIECE(IVSN0,"~"),1:IVSN0)
- +2 SET (VSNDRDA,VCNT)=0
- FOR
- SET VSNDRDA=$ORDER(^PSDRUG("AVSN",IVSN,VSNDRDA))
- IF VSNDRDA'>0
- QUIT
- Begin DoDot:1
- +3 SET VSNSYNDA=0
- FOR
- SET VSNSYNDA=$ORDER(^PSDRUG("AVSN",IVSN,VSNDRDA,VSNSYNDA))
- IF VSNSYNDA'>0
- QUIT
- SET VCNT=VCNT+1
- SET VSNDRD0=VSNDRDA
- SET VSNSYND0=VSNSYNDA
- End DoDot:1
- +4 IF ((IVSN0["~")!(VCNT'=1))
- IF $DATA(^XTMP("PSAVSN",IVSN))
- SET VSNDUOU=^(IVSN)
- IF 1
- +5 IF '$TEST
- Begin DoDot:1
- +6 IF VCNT'=1
- QUIT
- +7 ; FYI both SYN and VSN values should be comming from the same Synonym
- +8 SET VSNIEN=VSNSYND0_","_VSNDRD0
- +9 SET VSNDUOU=$$GET1^DIQ(50.1,VSNIEN,403)
- End DoDot:1
- +10 IF VSNDUOU=""
- IF $DATA(^XTMP("PSAVSN",IVSN))
- SET VSNDUOU=^(IVSN)
- +11 ;
- SYNDUOU ;set SYNDUOU= to PSDRUG( or XTMP value
- +1 SET SYNIEN=SYNDA_","_DRDA
- +2 SET SYNDUOU=$$GET1^DIQ(50.1,SYNIEN,403)
- +3 IF '$LENGTH(SYNDUOU)
- IF $DATA(^XTMP("PSAVSN",IVSN))
- SET SYNDUOU=^(IVSN)
- Begin DoDot:1
- +4 IF SYNDUOU'=DRDUOU
- QUIT
- +5 LOCK +^PSDRUG(DRDA,1,SYNDA,0):10
- IF '$TEST
- QUIT
- +6 SET SYN0=^PSDRUG(DRDA,1,SYNDA,0)
- +7 SET $PIECE(SYN0,U,7)=SYNDUOU
- SET ^PSDRUG(DRDA,1,SYNDA,0)=SYN0
- +8 LOCK -^PSDRUG(DRDA,1,SYNDA,0)
- End DoDot:1
- +9 ;
- TESTDUOU ; test if DUOUs are =
- +1 IF VSNDUOU=SYNDUOU
- IF SYNDUOU=DRDUOU
- IF 1
- +2 ; DUOUs '= but maybe VSN & SYN agree, set into IT
- IF '$TEST
- Begin DoDot:1
- +3 IF '$LENGTH(VSNDUOU)
- QUIT
- +4 IF VSNDUOU=SYNDUOU
- SET $PIECE(XX,U,20)=VSNDUOU
- SET PSADATA=XX
- End DoDot:1
- GOTO Q
- SETDUOU ;set DUOU into PSAPV "IT"
- SET $PIECE(XX,U,20)=DRDUOU
- SET PSADATA=XX
- +1 ;test for OU change
- CHKOU SET DROUNM=$$GET1^DIQ(50,DRDA,12)
- +1 SET DROUDA=$$GET1^DIQ(50,DRDA,12,"I")
- +2 IF $EXTRACT(INVOUNM,1,2)'="EA"
- GOTO Q
- +3 SET $PIECE(XX,U,12)=DROUDA
- SET $PIECE(XX,U,13)=.5
- SET $PIECE(XX,U,14)=DT
- +4 SET PSADATA=XX
- Q ;W ! ZW VSNDUOU,SYNDUOU,DRDUOU,PSADATA W !
- +1 QUIT PSADATA
