- AQAQCONV ;IHS/ANMC/LJF - CONVERSION OF DATA TO NEW CREDENTIALS FILE; [ 07/27/92 5:41 PM ]
- ;;2.2;STAFF CREDENTIALS;;01 OCT 1992
- ;
- START ;>>> start of MAIN ROUTINE <<<
- W !!,"DATA CONVERSION TO NEW CREDENTIALS FILE WILL NOW RUN..."
- ;
- I '$O(^AQAQ(0)) W !!,*7,?10,"NO DATA TO CONVERT-BYPASSING..." Q
- I $O(^AQAQC(0)) W !!,*7,?10,"CONVERSION ALREADY RUN-BYPASSING..." Q
- ;
- S U="^"
- ;
- W !!?10,"CONVERSION RUNNING..."
- ;**> loop thru old file; find entries; do conversions
- S AQAQX=0
- F S AQAQX=$O(^AQAQ(AQAQX)) Q:AQAQX'=+AQAQX D
- .;
- .;**> increment zero node
- .S $P(^AQAQC(0),U,3)=AQAQX,$P(^(0),U,4)=$P(^(0),U,4)+1
- .;
- .;**> convert single node data
- .D CONVERT1
- .;
- .;**> convert data in health status multiple
- .S AQAQY=0,^AQAQC(AQAQX,"H",0)="^9002165.03D^^"
- .F S AQAQY=$O(^AQAQ(AQAQX,6,AQAQY)) Q:AQAQY'=+AQAQY D
- ..S ^AQAQC(AQAQX,"H",AQAQY,0)=$G(^AQAQ(AQAQX,6,AQAQY,0))
- ..S $P(^AQAQC(AQAQX,"H",0),U,3)=AQAQY
- ..S $P(^AQAQC(AQAQX,"H",0),U,4)=$P(^(0),U,4)+1
- .;
- .;**> convert data in credentials approval multiple
- .S AQAQY=$O(^AQAQ(AQAQX,9,0)) I AQAQY=+AQAQY D CONVERT2
- .;
- .;**> convert med board certification data multiple
- .S AQAQY=0,AQAQP=$P(AQAQ0,U) K AQAQA
- .;sort old data by board and then by date into array
- .F S AQAQY=$O(^AQAQ(AQAQX,1,AQAQY)) Q:AQAQY'=+AQAQY D
- ..S AQAQS=$G(^AQAQ(AQAQX,1,AQAQY,0))
- ..Q:$P(AQAQS,U)="" Q:$P(AQAQS,U,2)=""
- ..S AQAQA($P(AQAQS,U,2),$P(AQAQS,U))=$P(AQAQS,U,3)
- .;
- .;for each board set original certification plus recert. multiples
- .S AQAQB=0
- .F S AQAQB=$O(AQAQA(AQAQB)) Q:AQAQB="" D CONVERT3
- ;
- ;**> index file
- W !!?10,"FIRING CROSS-REFERENCES..."
- S DIU(0)="",DIK="^AQAQC(" D IXALL^DIK K DIU(0)
- ;
- END W !!?10,"CONVERSION COMPLETE!!!"
- K AQAQ0,AQAQ2,AQAQ7,AQAQ11,AQAQP,AQAQDA,DIC,DIK,X,Y
- K AQAQX,AQAQY,AQAQA,AQAQB,AQAQC,AQAQS,AQAQD,AQAQCT Q
- ;
- ;>>> end of MAIN ROUTINE <<<
- ;
- ;
- CONVERT1 ;***> SUBRTN to convert data from single nodes
- S AQAQ0=$G(^AQAQ(AQAQX,0))
- S AQAQ2=$G(^AQAQ(AQAQX,2))
- S AQAQ7=$G(^AQAQ(AQAQX,7))
- S AQAQ11=$G(^AQAQ(AQAQX,11))
- S $P(^AQAQC(AQAQX,0),U,1,3)=$P(AQAQ0,U,1,3)
- S $P(^(0),U,11)=$P(AQAQ0,U,4),$P(^(0),U,7)=$P(AQAQ0,U,5)
- S $P(^(0),U,5)=$P(AQAQ0,U,6),$P(^(0),U,6)=$P(AQAQ0,U,14)
- S $P(^(0),U,13)=$P(AQAQ0,U,9),$P(^(0),U,15)=$P(AQAQ0,U,11)
- S $P(^(0),U,14)=$P(AQAQ0,U,10)
- I $P(AQAQ0,U,13)="Y" S $P(^(0),U,17,18)="3^Y"
- S $P(^AQAQC(AQAQX,0),U,19)=AQAQ2
- S $P(^AQAQC(AQAQX,2),U,3)=$P(AQAQ7,U)
- S $P(^AQAQC(AQAQX,2),U,1,2)=$P(AQAQ11,U,2,3)
- S $P(^(2),U,4)=$P(AQAQ11,U)
- Q
- ;
- ;
- CONVERT2 ;***> SUBRTN to move credentials approval data to reappointment multi
- S $P(^AQAQC(AQAQX,0),U,4)=$P($G(^AQAQ(AQAQX,9,AQAQY,0)),U)
- S ^AQAQC(AQAQX,"R",0)="^9002165.01D^^",AQAQY=0
- F S AQAQY=$O(^AQAQ(AQAQX,9,AQAQY)) Q:AQAQY'=+AQAQY D
- .S $P(^AQAQC(AQAQX,"R",AQAQY,0),U)=$E($P($G(^AQAQ(AQAQX,9,AQAQY,0)),U),1,5)_"00"
- .S $P(^AQAQC(AQAQX,"R",AQAQY,0),U,2)=$P($G(^AQAQ(AQAQX,9,AQAQY,0)),U)
- .S $P(^AQAQC(AQAQX,"R",0),U,3)=AQAQY
- .S $P(^AQAQC(AQAQX,"R",0),U,4)=$P(^(0),U,4)+1
- Q
- ;
- ;
- CONVERT3 ;***> SUBRTN to move med board data to Med Board Certification file
- S AQAQD=$O(AQAQA(AQAQB,0)),DIC="^AQAQMB(",DIC(0)="L",X=AQAQB
- S DIC("DR")=".02///^S X=""`""_AQAQP;.03///^S X=AQAQD;.04///^S X=AQAQA(AQAQB,AQAQD)"
- D FILE^DICN S AQAQDA=+Y
- ;create recertification date multiples for that board
- S ^AQAQMB(AQAQDA,1,0)="^9002161.11D^^",AQAQCT=0
- F S AQAQD=$O(AQAQA(AQAQB,AQAQD)) Q:AQAQD="" D
- .S AQAQCT=AQAQCT+1,$P(^AQAQMB(AQAQDA,1,0),U,3)=AQAQCT
- .S $P(^AQAQMB(AQAQDA,1,0),U,4)=$P(^(0),U,4)+1
- .S ^AQAQMB(AQAQDA,1,AQAQCT,0)=AQAQD_U_AQAQA(AQAQB,AQAQD)
- Q
- AQAQCONV ;IHS/ANMC/LJF - CONVERSION OF DATA TO NEW CREDENTIALS FILE; [ 07/27/92 5:41 PM ]
- +1 ;;2.2;STAFF CREDENTIALS;;01 OCT 1992
- +2 ;
- START ;>>> start of MAIN ROUTINE <<<
- +1 WRITE !!,"DATA CONVERSION TO NEW CREDENTIALS FILE WILL NOW RUN..."
- +2 ;
- +3 IF '$ORDER(^AQAQ(0))
- WRITE !!,*7,?10,"NO DATA TO CONVERT-BYPASSING..."
- QUIT
- +4 IF $ORDER(^AQAQC(0))
- WRITE !!,*7,?10,"CONVERSION ALREADY RUN-BYPASSING..."
- QUIT
- +5 ;
- +6 SET U="^"
- +7 ;
- +8 WRITE !!?10,"CONVERSION RUNNING..."
- +9 ;**> loop thru old file; find entries; do conversions
- +10 SET AQAQX=0
- +11 FOR
- SET AQAQX=$ORDER(^AQAQ(AQAQX))
- IF AQAQX'=+AQAQX
- QUIT
- Begin DoDot:1
- +12 ;
- +13 ;**> increment zero node
- +14 SET $PIECE(^AQAQC(0),U,3)=AQAQX
- SET $PIECE(^(0),U,4)=$PIECE(^(0),U,4)+1
- +15 ;
- +16 ;**> convert single node data
- +17 DO CONVERT1
- +18 ;
- +19 ;**> convert data in health status multiple
- +20 SET AQAQY=0
- SET ^AQAQC(AQAQX,"H",0)="^9002165.03D^^"
- +21 FOR
- SET AQAQY=$ORDER(^AQAQ(AQAQX,6,AQAQY))
- IF AQAQY'=+AQAQY
- QUIT
- Begin DoDot:2
- +22 SET ^AQAQC(AQAQX,"H",AQAQY,0)=$GET(^AQAQ(AQAQX,6,AQAQY,0))
- +23 SET $PIECE(^AQAQC(AQAQX,"H",0),U,3)=AQAQY
- +24 SET $PIECE(^AQAQC(AQAQX,"H",0),U,4)=$PIECE(^(0),U,4)+1
- End DoDot:2
- +25 ;
- +26 ;**> convert data in credentials approval multiple
- +27 SET AQAQY=$ORDER(^AQAQ(AQAQX,9,0))
- IF AQAQY=+AQAQY
- DO CONVERT2
- +28 ;
- +29 ;**> convert med board certification data multiple
- +30 SET AQAQY=0
- SET AQAQP=$PIECE(AQAQ0,U)
- KILL AQAQA
- +31 ;sort old data by board and then by date into array
- +32 FOR
- SET AQAQY=$ORDER(^AQAQ(AQAQX,1,AQAQY))
- IF AQAQY'=+AQAQY
- QUIT
- Begin DoDot:2
- +33 SET AQAQS=$GET(^AQAQ(AQAQX,1,AQAQY,0))
- +34 IF $PIECE(AQAQS,U)=""
- QUIT
- IF $PIECE(AQAQS,U,2)=""
- QUIT
- +35 SET AQAQA($PIECE(AQAQS,U,2),$PIECE(AQAQS,U))=$PIECE(AQAQS,U,3)
- End DoDot:2
- +36 ;
- +37 ;for each board set original certification plus recert. multiples
- +38 SET AQAQB=0
- +39 FOR
- SET AQAQB=$ORDER(AQAQA(AQAQB))
- IF AQAQB=""
- QUIT
- DO CONVERT3
- End DoDot:1
- +40 ;
- +41 ;**> index file
- +42 WRITE !!?10,"FIRING CROSS-REFERENCES..."
- +43 SET DIU(0)=""
- SET DIK="^AQAQC("
- DO IXALL^DIK
- KILL DIU(0)
- +44 ;
- END WRITE !!?10,"CONVERSION COMPLETE!!!"
- +1 KILL AQAQ0,AQAQ2,AQAQ7,AQAQ11,AQAQP,AQAQDA,DIC,DIK,X,Y
- +2 KILL AQAQX,AQAQY,AQAQA,AQAQB,AQAQC,AQAQS,AQAQD,AQAQCT
- QUIT
- +3 ;
- +4 ;>>> end of MAIN ROUTINE <<<
- +5 ;
- +6 ;
- CONVERT1 ;***> SUBRTN to convert data from single nodes
- +1 SET AQAQ0=$GET(^AQAQ(AQAQX,0))
- +2 SET AQAQ2=$GET(^AQAQ(AQAQX,2))
- +3 SET AQAQ7=$GET(^AQAQ(AQAQX,7))
- +4 SET AQAQ11=$GET(^AQAQ(AQAQX,11))
- +5 SET $PIECE(^AQAQC(AQAQX,0),U,1,3)=$PIECE(AQAQ0,U,1,3)
- +6 SET $PIECE(^(0),U,11)=$PIECE(AQAQ0,U,4)
- SET $PIECE(^(0),U,7)=$PIECE(AQAQ0,U,5)
- +7 SET $PIECE(^(0),U,5)=$PIECE(AQAQ0,U,6)
- SET $PIECE(^(0),U,6)=$PIECE(AQAQ0,U,14)
- +8 SET $PIECE(^(0),U,13)=$PIECE(AQAQ0,U,9)
- SET $PIECE(^(0),U,15)=$PIECE(AQAQ0,U,11)
- +9 SET $PIECE(^(0),U,14)=$PIECE(AQAQ0,U,10)
- +10 IF $PIECE(AQAQ0,U,13)="Y"
- SET $PIECE(^(0),U,17,18)="3^Y"
- +11 SET $PIECE(^AQAQC(AQAQX,0),U,19)=AQAQ2
- +12 SET $PIECE(^AQAQC(AQAQX,2),U,3)=$PIECE(AQAQ7,U)
- +13 SET $PIECE(^AQAQC(AQAQX,2),U,1,2)=$PIECE(AQAQ11,U,2,3)
- +14 SET $PIECE(^(2),U,4)=$PIECE(AQAQ11,U)
- +15 QUIT
- +16 ;
- +17 ;
- CONVERT2 ;***> SUBRTN to move credentials approval data to reappointment multi
- +1 SET $PIECE(^AQAQC(AQAQX,0),U,4)=$PIECE($GET(^AQAQ(AQAQX,9,AQAQY,0)),U)
- +2 SET ^AQAQC(AQAQX,"R",0)="^9002165.01D^^"
- SET AQAQY=0
- +3 FOR
- SET AQAQY=$ORDER(^AQAQ(AQAQX,9,AQAQY))
- IF AQAQY'=+AQAQY
- QUIT
- Begin DoDot:1
- +4 SET $PIECE(^AQAQC(AQAQX,"R",AQAQY,0),U)=$EXTRACT($PIECE($GET(^AQAQ(AQAQX,9,AQAQY,0)),U),1,5)_"00"
- +5 SET $PIECE(^AQAQC(AQAQX,"R",AQAQY,0),U,2)=$PIECE($GET(^AQAQ(AQAQX,9,AQAQY,0)),U)
- +6 SET $PIECE(^AQAQC(AQAQX,"R",0),U,3)=AQAQY
- +7 SET $PIECE(^AQAQC(AQAQX,"R",0),U,4)=$PIECE(^(0),U,4)+1
- End DoDot:1
- +8 QUIT
- +9 ;
- +10 ;
- CONVERT3 ;***> SUBRTN to move med board data to Med Board Certification file
- +1 SET AQAQD=$ORDER(AQAQA(AQAQB,0))
- SET DIC="^AQAQMB("
- SET DIC(0)="L"
- SET X=AQAQB
- +2 SET DIC("DR")=".02///^S X=""`""_AQAQP;.03///^S X=AQAQD;.04///^S X=AQAQA(AQAQB,AQAQD)"
- +3 DO FILE^DICN
- SET AQAQDA=+Y
- +4 ;create recertification date multiples for that board
- +5 SET ^AQAQMB(AQAQDA,1,0)="^9002161.11D^^"
- SET AQAQCT=0
- +6 FOR
- SET AQAQD=$ORDER(AQAQA(AQAQB,AQAQD))
- IF AQAQD=""
- QUIT
- Begin DoDot:1
- +7 SET AQAQCT=AQAQCT+1
- SET $PIECE(^AQAQMB(AQAQDA,1,0),U,3)=AQAQCT
- +8 SET $PIECE(^AQAQMB(AQAQDA,1,0),U,4)=$PIECE(^(0),U,4)+1
- +9 SET ^AQAQMB(AQAQDA,1,AQAQCT,0)=AQAQD_U_AQAQA(AQAQB,AQAQD)
- End DoDot:1
- +10 QUIT
