PSJ010 ;BIR/RSB-UTILITY ROUTINE FOR PSJ*5.0*10 ; 15 Apr 98 / 8:01 AM
;;5.0; INPATIENT MEDICATIONS ;**10**;16 DEC 97
;
D 1,2,3 Q
; ***** Convert field .13 and .14 in 59.6 to fields .19 and .2
1 N X,PSJW,PSJP,PSJN,PSJF
F PSJW=0:0 S PSJW=$O(^PS(59.6,PSJW)) Q:'PSJW D
.F PSJF=13,14 D
..I $L($P($G(^PS(59.6,PSJW,0)),"^",PSJF)) S PSJN=$P(^(0),"^",PSJF) D
...K DIC S X=PSJN,DIC="^%ZIS(1,",DIC(0)="XOS" D ^DIC S:+Y>0 $P(^PS(59.6,PSJW,0),"^",(PSJF+6))=+Y
Q
;
;
; ***** Convert field .07 in 53.45 to field .13
2 N X,PSJW,PSJP,PSJN,PSJF
F PSJW=0:0 S PSJW=$O(^PS(53.45,PSJW)) Q:'PSJW D
.F PSJF=7 D
..I $L($P($G(^PS(53.45,PSJW,0)),"^",PSJF)) S PSJN=$P(^(0),"^",PSJF) D
...K DIC S X=PSJN,DIC="^%ZIS(1,",DIC(0)="XOS" D ^DIC S:+Y>0 $P(^PS(53.45,PSJW,0),"^",(PSJF+6))=+Y
Q
;
;
; ***** Convert field 30 in 57.5 to field 32
3 N X,PSJW,PSJP,PSJN,PSJF
F PSJW=0:0 S PSJW=$O(^PS(57.5,PSJW)) Q:'PSJW D
.F PSJF=1 D
..I $L($P($G(^PS(57.5,PSJW,3)),"^",PSJF)) S PSJN=$P(^(3),"^",PSJF) D
...K DIC S X=PSJN,DIC="^%ZIS(1,",DIC(0)="XOS" D ^DIC S:+Y>0 $P(^PS(57.5,PSJW,3),"^",(PSJF+2))=+Y
Q
PSJ010 ;BIR/RSB-UTILITY ROUTINE FOR PSJ*5.0*10 ; 15 Apr 98 / 8:01 AM
+1 ;;5.0; INPATIENT MEDICATIONS ;**10**;16 DEC 97
+2 ;
+3 DO 1
DO 2
DO 3
QUIT
+4 ; ***** Convert field .13 and .14 in 59.6 to fields .19 and .2
1 NEW X,PSJW,PSJP,PSJN,PSJF
+1 FOR PSJW=0:0
SET PSJW=$ORDER(^PS(59.6,PSJW))
IF 'PSJW
QUIT
Begin DoDot:1
+2 FOR PSJF=13,14
Begin DoDot:2
+3 IF $LENGTH($PIECE($GET(^PS(59.6,PSJW,0)),"^",PSJF))
SET PSJN=$PIECE(^(0),"^",PSJF)
Begin DoDot:3
+4 KILL DIC
SET X=PSJN
SET DIC="^%ZIS(1,"
SET DIC(0)="XOS"
DO ^DIC
IF +Y>0
SET $PIECE(^PS(59.6,PSJW,0),"^",(PSJF+6))=+Y
End DoDot:3
End DoDot:2
End DoDot:1
+5 QUIT
+6 ;
+7 ;
+8 ; ***** Convert field .07 in 53.45 to field .13
2 NEW X,PSJW,PSJP,PSJN,PSJF
+1 FOR PSJW=0:0
SET PSJW=$ORDER(^PS(53.45,PSJW))
IF 'PSJW
QUIT
Begin DoDot:1
+2 FOR PSJF=7
Begin DoDot:2
+3 IF $LENGTH($PIECE($GET(^PS(53.45,PSJW,0)),"^",PSJF))
SET PSJN=$PIECE(^(0),"^",PSJF)
Begin DoDot:3
+4 KILL DIC
SET X=PSJN
SET DIC="^%ZIS(1,"
SET DIC(0)="XOS"
DO ^DIC
IF +Y>0
SET $PIECE(^PS(53.45,PSJW,0),"^",(PSJF+6))=+Y
End DoDot:3
End DoDot:2
End DoDot:1
+5 QUIT
+6 ;
+7 ;
+8 ; ***** Convert field 30 in 57.5 to field 32
3 NEW X,PSJW,PSJP,PSJN,PSJF
+1 FOR PSJW=0:0
SET PSJW=$ORDER(^PS(57.5,PSJW))
IF 'PSJW
QUIT
Begin DoDot:1
+2 FOR PSJF=1
Begin DoDot:2
+3 IF $LENGTH($PIECE($GET(^PS(57.5,PSJW,3)),"^",PSJF))
SET PSJN=$PIECE(^(3),"^",PSJF)
Begin DoDot:3
+4 KILL DIC
SET X=PSJN
SET DIC="^%ZIS(1,"
SET DIC(0)="XOS"
DO ^DIC
IF +Y>0
SET $PIECE(^PS(57.5,PSJW,3),"^",(PSJF+2))=+Y
End DoDot:3
End DoDot:2
End DoDot:1
+5 QUIT
